From 89c10ed221762cb73a48405405e0b1ac72a6c1e6 Mon Sep 17 00:00:00 2001 From: Bartosz Sypytkowski Date: Tue, 12 Jul 2016 07:24:20 +0200 Subject: [PATCH 1/7] planning phase --- src/FSharp.Data.GraphQL/Execution.fs | 10 +- .../FSharp.Data.GraphQL.fsproj | 1 + src/FSharp.Data.GraphQL/Planning.fs | 251 ++++++++++++++++++ src/FSharp.Data.GraphQL/TypeSystem.fs | 16 +- 4 files changed, 265 insertions(+), 13 deletions(-) create mode 100644 src/FSharp.Data.GraphQL/Planning.fs diff --git a/src/FSharp.Data.GraphQL/Execution.fs b/src/FSharp.Data.GraphQL/Execution.fs index 61356162c..05ef2c681 100644 --- a/src/FSharp.Data.GraphQL/Execution.fs +++ b/src/FSharp.Data.GraphQL/Execution.fs @@ -157,7 +157,8 @@ let private coerceDirectiveValue (ctx: ExecutionContext) (directive: Directive) | other -> match coerceBoolInput other with | Some s -> s - | None -> raise (GraphQLException (sprintf "Expected 'if' argument of directive '@%s' to have boolean value but got %A" directive.Name other)) + | None -> raise ( + GraphQLException (sprintf "Expected 'if' argument of directive '@%s' to have boolean value but got %A" directive.Name other)) let private shouldSkip (ctx: ExecutionContext) (directive: Directive) = match directive.Name with @@ -309,7 +310,8 @@ let rec createCompletion (possibleTypesFn: TypeDef -> ObjectDef []) (returnDef: |> Seq.map (fun x -> innerfn ctx x) |> Job.conCollect return completed.ToArray() :> obj - | _ -> return raise (GraphQLException (sprintf "Expected to have enumerable value in field '%s' but got '%O'" ctx.FieldName (value.GetType()))) + | _ -> return raise ( + GraphQLException (sprintf "Expected to have enumerable value in field '%s' but got '%O'" ctx.FieldName (value.GetType()))) } | Nullable (Output innerdef) -> let innerfn = createCompletion possibleTypesFn innerdef @@ -369,7 +371,7 @@ and private getFieldDefinition (ctx: ExecutionContext) (objectType: ObjectDef) ( | "__schema" when Object.ReferenceEquals(ctx.Schema.Query, objectType) -> Some (upcast SchemaMetaFieldDef) | "__type" when Object.ReferenceEquals(ctx.Schema.Query, objectType) -> Some (upcast TypeMetaFieldDef) | "__typename" -> Some (upcast TypeNameMetaFieldDef) - | fieldName -> objectType.Fields |> Array.tryFind (fun f -> f.Name = fieldName) + | fieldName -> objectType.Fields |> Map.tryFind fieldName and private getFieldEntry (ctx: ExecutionContext) typedef value (fields: Field []) : Job = let firstField = fields.[0] @@ -432,7 +434,7 @@ let internal compileSchema possibleTypesFn types = match x with | Object objdef -> objdef.Fields - |> Array.iter (fun fieldDef -> + |> Map.iter (fun _ fieldDef -> fieldDef.Execute <- compileField possibleTypesFn fieldDef fieldDef.Args |> Array.iter (fun arg -> diff --git a/src/FSharp.Data.GraphQL/FSharp.Data.GraphQL.fsproj b/src/FSharp.Data.GraphQL/FSharp.Data.GraphQL.fsproj index 3ec74b723..b2c14f2be 100644 --- a/src/FSharp.Data.GraphQL/FSharp.Data.GraphQL.fsproj +++ b/src/FSharp.Data.GraphQL/FSharp.Data.GraphQL.fsproj @@ -52,6 +52,7 @@ + diff --git a/src/FSharp.Data.GraphQL/Planning.fs b/src/FSharp.Data.GraphQL/Planning.fs new file mode 100644 index 000000000..6f2425068 --- /dev/null +++ b/src/FSharp.Data.GraphQL/Planning.fs @@ -0,0 +1,251 @@ +module FSharp.Data.GraphQL.Planning + +open System +open System.Reflection +open System.Collections.Generic +open System.Collections.Concurrent +open FSharp.Data.GraphQL.Ast +open FSharp.Data.GraphQL.Types +open FSharp.Data.GraphQL.Types.Introspection +open FSharp.Data.GraphQL.Introspection + +let SchemaMetaFieldDef = Define.Field( + name = "__schema", + description = "Access the current type schema of this server.", + typedef = __Schema, + resolve = fun ctx (_: obj) -> ctx.Schema.Introspected) + +let TypeMetaFieldDef = Define.Field( + name = "__type", + description = "Request the type information of a single type.", + typedef = __Type, + args = [ + { Name = "name" + Description = None + Type = String + DefaultValue = None + ExecuteInput = variableOrElse(coerceStringInput >> Option.map box >> Option.toObj) } + ], + resolve = fun ctx (_:obj) -> + ctx.Schema.Introspected.Types + |> Seq.find (fun t -> t.Name = ctx.Arg("name")) + |> IntrospectionTypeRef.Named) + +let TypeNameMetaFieldDef : FieldDef = Define.Field( + name = "__typename", + description = "The name of the current Object type at runtime.", + typedef = String, + resolve = fun ctx (_:obj) -> ctx.ParentType.Name) + +let private tryFindDef (schema: ISchema) (objdef: ObjectDef) (field: Field) : FieldDef option = + match field.Name with + | "__schema" when Object.ReferenceEquals(schema.Query, objdef) -> Some (upcast SchemaMetaFieldDef) + | "__type" when Object.ReferenceEquals(schema.Query, objdef) -> Some (upcast TypeMetaFieldDef) + | "__typename" -> Some (upcast TypeNameMetaFieldDef) + | fieldName -> objdef.Fields |> Map.tryFind fieldName + +type PlanningContext = + { Schema: ISchema + Document: Document } + +type Includer = Map -> bool +type PlanningData = + { ParentDef: ObjectDef + Definition: FieldDef + IsNullable: bool + Ast: Field } + static member Create(ctx: PlanningContext, parentDef: ObjectDef, field: Field) : PlanningData = + match tryFindDef ctx.Schema parentDef field with + | Some fdef -> + { ParentDef = parentDef + Definition = fdef + Ast = field + IsNullable = fdef.Type :? NullableDef } + | None -> + raise (GraphQLException (sprintf "No field '%s' was defined in object definition '%s'" field.Name parentDef.Name)) + +/// plan of reduction being a result of application of a query AST on existing schema +type ExecutionPlan = + // reducer for scalar or enum + | ResolveValue of data:PlanningData + // reducer for selection set applied upon output object + | SelectFields of data:PlanningData * fields:ExecutionPlan list + // reducer for each of the collection elements + | ResolveCollection of data:PlanningData * elementPlan:ExecutionPlan + // reducer for union and interface types to be resolved into ReduceSelection at runtime + | ResolveAbstraction of data:PlanningData * chooseReduction:Map + member x.Data = + match x with + | ResolveValue(data) -> data + | SelectFields(data, _) -> data + | ResolveCollection(data, _) -> data + | ResolveAbstraction(data, _) -> data + + +let private coerceVariables (schema: #ISchema) (variables: VariableDefinition list) (inputs: Map option) = + match inputs with + | None -> + variables + |> List.filter (fun vardef -> Option.isSome vardef.DefaultValue) + |> List.fold (fun acc vardef -> + let variableName = vardef.VariableName + Map.add variableName (coerceVariable schema vardef Map.empty) acc) Map.empty + | Some vars -> + variables + |> List.fold (fun acc vardef -> + let variableName = vardef.VariableName + Map.add variableName (coerceVariable schema vardef vars) acc) Map.empty + +let private directiveIncluder (directive: Directive) : Includer = + fun variables -> + match directive.If.Value with + | Variable vname -> downcast variables.[vname] + | other -> + match coerceBoolInput other with + | Some s -> s + | None -> raise ( + GraphQLException (sprintf "Expected 'if' argument of directive '@%s' to have boolean value but got %A" directive.Name other)) + +let incl: Includer = fun _ -> true +let excl: Includer = fun _ -> false +let private getIncluder (directives: Directive list) : Includer = + directives + |> List.fold (fun acc directive -> + match directive.Name with + | "skip" -> + let excluder = directiveIncluder directive >> not + fun vars -> acc vars && excluder vars + | "include" -> + let includer = directiveIncluder directive + fun vars -> acc vars && includer vars + | _ -> acc) incl + +let private doesFragmentTypeApply (schema: ISchema) fragment (objectType: ObjectDef) = + match fragment.TypeCondition with + | None -> true + | Some typeCondition -> + match schema.TryFindType typeCondition with + | None -> false + | Some conditionalType when conditionalType.Name = objectType.Name -> true + | Some (Abstract conditionalType) -> schema.IsPossibleType conditionalType objectType + | _ -> false + +//let rec private findGroupIndexByName (groupedFields: System.Collections.Generic.List) (name: string) (i: int) : int = +// if i < 0 +// then -1 +// else +// let (k, _) = groupedFields.[i] +// if k = name then i +// else findGroupIndexByName groupedFields name (i-1) +// +//let rec private groupFields (ctx: PlanningContext) typedef (selectionSet: Selection list) (visitedFragments): (string * Field []) [] = +// let groupedFields = System.Collections.Generic.List(selectionSet.Length) +// selectionSet +// |> List.iteri(fun i selection -> +// match selection with +// | Field field -> +// let name = field.AliasOrName +// match findGroupIndexByName groupedFields name (groupedFields.Count-1) with +// | -1 -> +// groupedFields.Add (name, [| field |]) +// | idx -> +// let (_, value) = groupedFields.[idx] +// groupedFields.[idx] <- (name, Array.append [| field |] value) +// | FragmentSpread spread -> +// let fragmentSpreadName = spread.Name +// if not (List.exists (fun fragmentName -> fragmentName = fragmentSpreadName) !visitedFragments) +// then +// visitedFragments := (fragmentSpreadName::!visitedFragments) +// let found = +// ctx.Document.Definitions +// |> List.tryFind (function FragmentDefinition f when f.Name.Value = fragmentSpreadName -> true | _ -> false) +// match found with +// | Some (FragmentDefinition fragment) -> +// if doesFragmentTypeApply ctx.Schema fragment typedef +// then +// let fragmentSelectionSet = fragment.SelectionSet +// let fragmentGroupedFieldSet = groupFields ctx typedef fragmentSelectionSet visitedFragments +// for j = 0 to fragmentGroupedFieldSet.Length - 1 do +// let (responseKey, fragmentGroup) = fragmentGroupedFieldSet.[j] +// match findGroupIndexByName groupedFields responseKey (groupedFields.Count-1) with +// | -1 -> +// groupedFields.Add (responseKey, fragmentGroup) +// | idx -> +// let (_, value) = groupedFields.[idx] +// groupedFields.[idx] <- (responseKey, Array.append fragmentGroup value) +// | _ -> () +// | InlineFragment fragment -> +// if doesFragmentTypeApply ctx.Schema fragment typedef +// then +// let fragmentSelectionSet = fragment.SelectionSet +// let fragmentGroupedFieldSet = groupFields ctx typedef fragmentSelectionSet visitedFragments +// for j = 0 to fragmentGroupedFieldSet.Length - 1 do +// let (responseKey, fragmentGroup) = fragmentGroupedFieldSet.[j] +// match findGroupIndexByName groupedFields responseKey (groupedFields.Count-1) with +// | -1 -> +// groupedFields.Add (responseKey, fragmentGroup) +// | idx -> +// let (_, value) = groupedFields.[idx] +// groupedFields.[idx] <- (responseKey, Array.append fragmentGroup value)) +// groupedFields.ToArray() + +let rec private plan (ctx: PlanningContext) (data: PlanningData) (typedef: TypeDef) : ExecutionPlan = + match typedef with + | Leaf leafDef -> planLeaf ctx data leafDef + | Object objDef -> planSelection ctx { data with ParentDef = objDef } data.Ast.SelectionSet (ref []) + | Nullable innerDef -> plan ctx { data with IsNullable = true } innerDef + | List innerDef -> planList ctx data innerDef + | Abstract abstractDef -> planAbstraction ctx data abstractDef + +and private planSelection (ctx: PlanningContext) (data: PlanningData) (selectionSet: Selection list) visitedFragments : ExecutionPlan = + let plannedFields = + selectionSet + |> List.fold(fun fields selection -> + match selection with + | Field field -> + let identifier = field.AliasOrName + match fields |> List.tryFindIndex (fun (name, f) -> name = identifier) with + | None -> + let data = PlanningData.Create(ctx, data.ParentDef, field) + let executionPlan = plan ctx data data.Definition.Type + (identifier, executionPlan)::fields + | Some _ -> fields + | FragmentSpread spread -> + let spreadName = spread.Name + if !visitedFragments |> List.exists (fun name -> name = spreadName) + then fields // fragment already found + else + visitedFragments := spreadName::!visitedFragments + match ctx.Document.Definitions |> List.tryFind (function FragmentDefinition f -> f.Name.Value = spreadName | _ -> false) with + | Some (FragmentDefinition fragment) when doesFragmentTypeApply ctx.Schema fragment data.ParentDef -> + // retrieve fragment data just as it was normal selection set + let (SelectFields(_, fragmentFields)) = planSelection ctx data fragment.SelectionSet visitedFragments + // filter out already existing fields + let distinctFields = + fragmentFields + |> List.map (fun plan -> (plan.Data.Ast.AliasOrName, plan)) + |> List.filter (fun (ffname, _) -> not <| List.exists (fun (name, _) -> name = ffname) fields) + distinctFields @ fields + | _ -> fields + | InlineFragment fragment when doesFragmentTypeApply ctx.Schema fragment data.ParentDef -> + // retrieve fragment data just as it was normal selection set + let (SelectFields(_, fragmentFields)) = planSelection ctx data fragment.SelectionSet visitedFragments + // filter out already existing fields + let distinctFields = + fragmentFields + |> List.map (fun plan -> (plan.Data.Ast.AliasOrName, plan)) + |> List.filter (fun (ffname, _) -> not <| List.exists (fun (name, _) -> name = ffname) fields) + distinctFields @ fields + | _ -> fields + ) [] + SelectFields(data, plannedFields |> List.map snd) +and private planList (ctx: PlanningContext) (data: PlanningData) (innerDef: TypeDef) : ExecutionPlan = + ResolveCollection(data, plan ctx data innerDef) +and private planLeaf (ctx: PlanningContext) (data: PlanningData) (leafDef: LeafDef) : ExecutionPlan = + ResolveValue(data) +and private planAbstraction (ctx:PlanningContext) (data: PlanningData) (abstractDef: AbstractDef) : ExecutionPlan = + + ResolveAbstraction(data,) + +let planOperation (ctx: PlanningContext) (operation: OperationDefinition) : ExecutionPlan = + planSelection ctx () (downcast ctx.ParentDef) operation.SelectionSet \ No newline at end of file diff --git a/src/FSharp.Data.GraphQL/TypeSystem.fs b/src/FSharp.Data.GraphQL/TypeSystem.fs index 530f54118..f70dcbdc2 100644 --- a/src/FSharp.Data.GraphQL/TypeSystem.fs +++ b/src/FSharp.Data.GraphQL/TypeSystem.fs @@ -411,7 +411,7 @@ and ObjectDef = interface abstract Name : string abstract Description : string option - abstract Fields : FieldDef [] + abstract Fields : Map abstract Implements : InterfaceDef [] abstract IsTypeOf : (obj -> bool) option inherit TypeDef @@ -423,7 +423,7 @@ and ObjectDef = and ObjectDef<'Val> = interface - abstract Fields : FieldDef<'Val> [] + abstract Fields : Map> inherit ObjectDef inherit TypeDef<'Val> inherit OutputDef<'Val> @@ -432,7 +432,7 @@ and ObjectDef<'Val> = and [] ObjectDefinition<'Val> = { Name : string Description : string option - FieldsFn : Lazy []> + FieldsFn : Lazy>> Implements : InterfaceDef [] IsTypeOf : (obj -> bool) option } @@ -453,9 +453,7 @@ and [] ObjectDefinition<'Val> = member x.Fields = x.FieldsFn.Force() - |> Seq.ofArray - |> Seq.cast - |> Seq.toArray + |> Map.map (fun k v -> upcast v) member x.Implements = x.Implements member x.IsTypeOf = x.IsTypeOf @@ -1106,7 +1104,7 @@ module SchemaDefinitions = let (|Leaf|_|) (tdef : TypeDef) = match tdef with - | :? ScalarDef | :? EnumDef -> Some tdef + | :? LeafDef as ldef -> Some ldef | _ -> None let (|Composite|_|) (tdef : TypeDef) = @@ -1279,7 +1277,7 @@ module SchemaDefinitions = ?interfaces : InterfaceDef list, ?isTypeOf : obj -> bool) : ObjectDef<'Val> = upcast { Name = name Description = description - FieldsFn = lazy (fieldsFn() |> List.toArray) + FieldsFn = lazy (fieldsFn() |> List.map (fun f -> f.Name, f) |> Map.ofList) Implements = defaultArg (Option.map List.toArray interfaces) [||] IsTypeOf = isTypeOf } @@ -1288,7 +1286,7 @@ module SchemaDefinitions = ?interfaces : InterfaceDef list, ?isTypeOf : obj -> bool) : ObjectDef<'Val> = upcast { Name = name Description = description - FieldsFn = lazy (fields |> List.toArray) + FieldsFn = lazy (fields |> List.map (fun f -> f.Name, f) |> Map.ofList) Implements = defaultArg (Option.map List.toArray interfaces) [||] IsTypeOf = isTypeOf } From 3c94156870a4600c11b8b07076af77c09084078b Mon Sep 17 00:00:00 2001 From: Bartosz Sypytkowski Date: Tue, 12 Jul 2016 14:04:01 +0200 Subject: [PATCH 2/7] core planning phase construction ready --- src/FSharp.Data.GraphQL/Planning.fs | 164 ++++++++---------- src/FSharp.Data.GraphQL/Prolog.fs | 15 ++ src/FSharp.Data.GraphQL/Schema.fs | 4 + src/FSharp.Data.GraphQL/TypeSystem.fs | 2 + .../FSharp.Data.GraphQL.Tests/SchemaTests.fs | 2 +- 5 files changed, 98 insertions(+), 89 deletions(-) diff --git a/src/FSharp.Data.GraphQL/Planning.fs b/src/FSharp.Data.GraphQL/Planning.fs index 6f2425068..b509ccdac 100644 --- a/src/FSharp.Data.GraphQL/Planning.fs +++ b/src/FSharp.Data.GraphQL/Planning.fs @@ -46,23 +46,40 @@ let private tryFindDef (schema: ISchema) (objdef: ObjectDef) (field: Field) : Fi type PlanningContext = { Schema: ISchema + RootDef: ObjectDef Document: Document } type Includer = Map -> bool type PlanningData = - { ParentDef: ObjectDef + { /// Field identifier, which may be either field name or alias. For top level execution plan it will be None. + Identifier: string option + /// Composite definition being the parent of the current field, execution plan refers to. + ParentDef: CompositeDef + /// Field definition of corresponding type found in current schema. Definition: FieldDef + /// Boolean value marking if null values are allowed. IsNullable: bool + /// AST node of the parsed query document. Ast: Field } - static member Create(ctx: PlanningContext, parentDef: ObjectDef, field: Field) : PlanningData = + static member FromObject(ctx: PlanningContext, parentDef: ObjectDef, field: Field) : PlanningData = match tryFindDef ctx.Schema parentDef field with | Some fdef -> - { ParentDef = parentDef + { Identifier = Some field.AliasOrName + ParentDef = parentDef Definition = fdef Ast = field IsNullable = fdef.Type :? NullableDef } | None -> raise (GraphQLException (sprintf "No field '%s' was defined in object definition '%s'" field.Name parentDef.Name)) + static member FromAbstraction(ctx: PlanningContext, parentDef: AbstractDef, field: Field) : Map = + let objDefs = ctx.Schema.GetPossibleTypes parentDef + objDefs + |> Array.choose (fun objDef -> + match tryFindDef ctx.Schema objDef field with + | Some fdef -> + Some (objDef.Name, { Identifier = Some field.AliasOrName; ParentDef = parentDef; Definition = fdef; Ast = field; IsNullable = fdef.Type :? NullableDef }) + | None -> None) + |> Map.ofArray /// plan of reduction being a result of application of a query AST on existing schema type ExecutionPlan = @@ -73,7 +90,7 @@ type ExecutionPlan = // reducer for each of the collection elements | ResolveCollection of data:PlanningData * elementPlan:ExecutionPlan // reducer for union and interface types to be resolved into ReduceSelection at runtime - | ResolveAbstraction of data:PlanningData * chooseReduction:Map + | ResolveAbstraction of data:PlanningData * typeFields:Map member x.Data = match x with | ResolveValue(data) -> data @@ -129,87 +146,29 @@ let private doesFragmentTypeApply (schema: ISchema) fragment (objectType: Object | Some conditionalType when conditionalType.Name = objectType.Name -> true | Some (Abstract conditionalType) -> schema.IsPossibleType conditionalType objectType | _ -> false - -//let rec private findGroupIndexByName (groupedFields: System.Collections.Generic.List) (name: string) (i: int) : int = -// if i < 0 -// then -1 -// else -// let (k, _) = groupedFields.[i] -// if k = name then i -// else findGroupIndexByName groupedFields name (i-1) -// -//let rec private groupFields (ctx: PlanningContext) typedef (selectionSet: Selection list) (visitedFragments): (string * Field []) [] = -// let groupedFields = System.Collections.Generic.List(selectionSet.Length) -// selectionSet -// |> List.iteri(fun i selection -> -// match selection with -// | Field field -> -// let name = field.AliasOrName -// match findGroupIndexByName groupedFields name (groupedFields.Count-1) with -// | -1 -> -// groupedFields.Add (name, [| field |]) -// | idx -> -// let (_, value) = groupedFields.[idx] -// groupedFields.[idx] <- (name, Array.append [| field |] value) -// | FragmentSpread spread -> -// let fragmentSpreadName = spread.Name -// if not (List.exists (fun fragmentName -> fragmentName = fragmentSpreadName) !visitedFragments) -// then -// visitedFragments := (fragmentSpreadName::!visitedFragments) -// let found = -// ctx.Document.Definitions -// |> List.tryFind (function FragmentDefinition f when f.Name.Value = fragmentSpreadName -> true | _ -> false) -// match found with -// | Some (FragmentDefinition fragment) -> -// if doesFragmentTypeApply ctx.Schema fragment typedef -// then -// let fragmentSelectionSet = fragment.SelectionSet -// let fragmentGroupedFieldSet = groupFields ctx typedef fragmentSelectionSet visitedFragments -// for j = 0 to fragmentGroupedFieldSet.Length - 1 do -// let (responseKey, fragmentGroup) = fragmentGroupedFieldSet.[j] -// match findGroupIndexByName groupedFields responseKey (groupedFields.Count-1) with -// | -1 -> -// groupedFields.Add (responseKey, fragmentGroup) -// | idx -> -// let (_, value) = groupedFields.[idx] -// groupedFields.[idx] <- (responseKey, Array.append fragmentGroup value) -// | _ -> () -// | InlineFragment fragment -> -// if doesFragmentTypeApply ctx.Schema fragment typedef -// then -// let fragmentSelectionSet = fragment.SelectionSet -// let fragmentGroupedFieldSet = groupFields ctx typedef fragmentSelectionSet visitedFragments -// for j = 0 to fragmentGroupedFieldSet.Length - 1 do -// let (responseKey, fragmentGroup) = fragmentGroupedFieldSet.[j] -// match findGroupIndexByName groupedFields responseKey (groupedFields.Count-1) with -// | -1 -> -// groupedFields.Add (responseKey, fragmentGroup) -// | idx -> -// let (_, value) = groupedFields.[idx] -// groupedFields.[idx] <- (responseKey, Array.append fragmentGroup value)) -// groupedFields.ToArray() - + let rec private plan (ctx: PlanningContext) (data: PlanningData) (typedef: TypeDef) : ExecutionPlan = match typedef with | Leaf leafDef -> planLeaf ctx data leafDef | Object objDef -> planSelection ctx { data with ParentDef = objDef } data.Ast.SelectionSet (ref []) | Nullable innerDef -> plan ctx { data with IsNullable = true } innerDef | List innerDef -> planList ctx data innerDef - | Abstract abstractDef -> planAbstraction ctx data abstractDef + | Abstract abstractDef -> planAbstraction ctx { data with ParentDef = abstractDef } data.Ast.SelectionSet (ref []) and private planSelection (ctx: PlanningContext) (data: PlanningData) (selectionSet: Selection list) visitedFragments : ExecutionPlan = + let parentDef = downcast data.ParentDef let plannedFields = selectionSet - |> List.fold(fun fields selection -> + |> List.fold(fun (fields: ExecutionPlan list) selection -> match selection with | Field field -> let identifier = field.AliasOrName - match fields |> List.tryFindIndex (fun (name, f) -> name = identifier) with - | None -> - let data = PlanningData.Create(ctx, data.ParentDef, field) + if fields |> List.exists (fun f -> f.Data.Identifier.Value = identifier) + then + let data = PlanningData.FromObject(ctx, parentDef, field) let executionPlan = plan ctx data data.Definition.Type - (identifier, executionPlan)::fields - | Some _ -> fields + executionPlan::fields + else fields | FragmentSpread spread -> let spreadName = spread.Name if !visitedFragments |> List.exists (fun name -> name = spreadName) @@ -217,35 +176,64 @@ and private planSelection (ctx: PlanningContext) (data: PlanningData) (selection else visitedFragments := spreadName::!visitedFragments match ctx.Document.Definitions |> List.tryFind (function FragmentDefinition f -> f.Name.Value = spreadName | _ -> false) with - | Some (FragmentDefinition fragment) when doesFragmentTypeApply ctx.Schema fragment data.ParentDef -> + | Some (FragmentDefinition fragment) when doesFragmentTypeApply ctx.Schema fragment parentDef -> // retrieve fragment data just as it was normal selection set let (SelectFields(_, fragmentFields)) = planSelection ctx data fragment.SelectionSet visitedFragments // filter out already existing fields - let distinctFields = - fragmentFields - |> List.map (fun plan -> (plan.Data.Ast.AliasOrName, plan)) - |> List.filter (fun (ffname, _) -> not <| List.exists (fun (name, _) -> name = ffname) fields) - distinctFields @ fields + List.mergeBy (fun field -> field.Data.Identifier) fields fragmentFields | _ -> fields - | InlineFragment fragment when doesFragmentTypeApply ctx.Schema fragment data.ParentDef -> + | InlineFragment fragment when doesFragmentTypeApply ctx.Schema fragment parentDef -> // retrieve fragment data just as it was normal selection set let (SelectFields(_, fragmentFields)) = planSelection ctx data fragment.SelectionSet visitedFragments // filter out already existing fields - let distinctFields = - fragmentFields - |> List.map (fun plan -> (plan.Data.Ast.AliasOrName, plan)) - |> List.filter (fun (ffname, _) -> not <| List.exists (fun (name, _) -> name = ffname) fields) - distinctFields @ fields + List.mergeBy (fun field -> field.Data.Identifier) fields fragmentFields | _ -> fields ) [] - SelectFields(data, plannedFields |> List.map snd) + SelectFields(data, plannedFields) + and private planList (ctx: PlanningContext) (data: PlanningData) (innerDef: TypeDef) : ExecutionPlan = ResolveCollection(data, plan ctx data innerDef) + and private planLeaf (ctx: PlanningContext) (data: PlanningData) (leafDef: LeafDef) : ExecutionPlan = ResolveValue(data) -and private planAbstraction (ctx:PlanningContext) (data: PlanningData) (abstractDef: AbstractDef) : ExecutionPlan = - - ResolveAbstraction(data,) + +and private planAbstraction (ctx:PlanningContext) (data: PlanningData) (selectionSet: Selection list) visitedFragments : ExecutionPlan = + let parentDef = downcast data.ParentDef + let plannedTypeFields = + selectionSet + |> List.fold(fun (fields: Map) selection -> + match selection with + | Field field -> + PlanningData.FromAbstraction(ctx, parentDef, field) + |> Map.map (fun typeName data -> [ plan ctx data data.Definition.Type ]) + |> Map.merge (fun typeName oldVal newVal -> oldVal @ newVal) fields + | FragmentSpread spread -> + let spreadName = spread.Name + if !visitedFragments |> List.exists (fun name -> name = spreadName) + then fields // fragment already found + else + visitedFragments := spreadName::!visitedFragments + match ctx.Document.Definitions |> List.tryFind (function FragmentDefinition f -> f.Name.Value = spreadName | _ -> false) with + | Some (FragmentDefinition fragment) -> + // retrieve fragment data just as it was normal selection set + let (ResolveAbstraction(_, fragmentFields)) = planAbstraction ctx data fragment.SelectionSet visitedFragments + // filter out already existing fields + Map.merge (fun typeName oldVal newVal -> oldVal @ newVal) fields fragmentFields + | _ -> fields + | InlineFragment fragment -> + // retrieve fragment data just as it was normal selection set + let (ResolveAbstraction(_, fragmentFields)) = planAbstraction ctx data fragment.SelectionSet visitedFragments + // filter out already existing fields + Map.merge (fun typeName oldVal newVal -> oldVal @ newVal) fields fragmentFields + | _ -> fields + ) Map.empty + ResolveAbstraction(data, plannedTypeFields) let planOperation (ctx: PlanningContext) (operation: OperationDefinition) : ExecutionPlan = - planSelection ctx () (downcast ctx.ParentDef) operation.SelectionSet \ No newline at end of file + let data = { + Identifier = None; + Ast = Unchecked.defaultof + IsNullable = false + ParentDef = ctx.RootDef + Definition = Unchecked.defaultof} + planSelection ctx data operation.SelectionSet (ref []) \ No newline at end of file diff --git a/src/FSharp.Data.GraphQL/Prolog.fs b/src/FSharp.Data.GraphQL/Prolog.fs index b441c2bf2..573e284b4 100644 --- a/src/FSharp.Data.GraphQL/Prolog.fs +++ b/src/FSharp.Data.GraphQL/Prolog.fs @@ -20,6 +20,21 @@ module Array = i <- i + 1 Array.sub temp 0 i +module List = + let mergeBy f listx listy = + let uniqx = + listx + |> List.filter (fun x -> not <| List.exists(fun y -> f(x) = f(y)) listy) + uniqx @ listy + +module Map = + let merge mergeFn mapx mapy = + mapy + |> Map.fold (fun acc ky vy -> + match Map.tryFind ky acc with + | Some vx -> Map.add ky (mergeFn ky vx vy) acc + | None -> Map.add ky vy acc) mapx + module Option = let toObj value = match value with None -> null | Some x -> x diff --git a/src/FSharp.Data.GraphQL/Schema.fs b/src/FSharp.Data.GraphQL/Schema.fs index 9736cfcbc..e7e1d7466 100644 --- a/src/FSharp.Data.GraphQL/Schema.fs +++ b/src/FSharp.Data.GraphQL/Schema.fs @@ -33,6 +33,8 @@ type Schema<'Root> (query: ObjectDef<'Root>, ?mutation: ObjectDef<'Root>, ?confi let ns' = addOrReturn objdef.Name typedef ns let withFields' = objdef.Fields + |> Map.toArray + |> Array.map snd |> Array.collect (fun x -> Array.append [| x.Type :> TypeDef |] (x.Args |> Array.map (fun a -> upcast a.Type))) |> Array.filter (fun (Named x) -> not (Map.containsKey x.Name ns')) |> Array.fold (fun n (Named t) -> insert n t) ns' @@ -151,6 +153,8 @@ type Schema<'Root> (query: ObjectDef<'Root>, ?mutation: ObjectDef<'Root>, ?confi | Object objdef -> let fields = objdef.Fields + |> Map.toArray + |> Array.map snd |> Array.map (introspectField namedTypes) let interfaces = objdef.Implements diff --git a/src/FSharp.Data.GraphQL/TypeSystem.fs b/src/FSharp.Data.GraphQL/TypeSystem.fs index f70dcbdc2..79dbc8e57 100644 --- a/src/FSharp.Data.GraphQL/TypeSystem.fs +++ b/src/FSharp.Data.GraphQL/TypeSystem.fs @@ -207,6 +207,8 @@ and CompositeDef = and AbstractDef = interface inherit TypeDef + // only abstract types are Interface and Union, which are both composite defs too + inherit CompositeDef end and NamedDef = diff --git a/tests/FSharp.Data.GraphQL.Tests/SchemaTests.fs b/tests/FSharp.Data.GraphQL.Tests/SchemaTests.fs index 57c741e68..b81a22f3a 100644 --- a/tests/FSharp.Data.GraphQL.Tests/SchemaTests.fs +++ b/tests/FSharp.Data.GraphQL.Tests/SchemaTests.fs @@ -26,4 +26,4 @@ let ``Object type should be able to merge fields with matching signatures from d Define.Field("speed", Int) Define.Field("acceleration", Int) ]) equals [ MovableType :> InterfaceDef; upcast Movable2Type ] (PersonType.Implements |> Array.toList ) - equals [ Define.Field("name", String) :> FieldDef; upcast Define.Field("speed", Int); upcast Define.Field("acceleration", Int) ] (( PersonType :> ObjectDef).Fields |> Array.toList) \ No newline at end of file + equals [ Define.Field("name", String) :> FieldDef; upcast Define.Field("speed", Int); upcast Define.Field("acceleration", Int) ] (( PersonType :> ObjectDef).Fields |> Map.toList |> List.map snd) \ No newline at end of file From 8a80bf2d653616a2b58d4cb4be4f97e920bedf94 Mon Sep 17 00:00:00 2001 From: Bartosz Sypytkowski Date: Wed, 13 Jul 2016 15:04:36 +0200 Subject: [PATCH 3/7] planning specs in progress --- src/FSharp.Data.GraphQL/Execution.fs | 2 +- src/FSharp.Data.GraphQL/Planning.fs | 11 +- src/FSharp.Data.GraphQL/Schema.fs | 20 ++ src/FSharp.Data.GraphQL/TypeSystem.fs | 2 +- .../FSharp.Data.GraphQL.Tests.fsproj | 1 + .../PlanningTests.fs | 203 ++++++++++++++++++ 6 files changed, 233 insertions(+), 6 deletions(-) create mode 100644 tests/FSharp.Data.GraphQL.Tests/PlanningTests.fs diff --git a/src/FSharp.Data.GraphQL/Execution.fs b/src/FSharp.Data.GraphQL/Execution.fs index 05ef2c681..901e39a45 100644 --- a/src/FSharp.Data.GraphQL/Execution.fs +++ b/src/FSharp.Data.GraphQL/Execution.fs @@ -129,7 +129,7 @@ let private getOperation = function | OperationDefinition odef -> Some odef | _ -> None -let private findOperation doc opName = +let internal findOperation doc opName = match doc.Definitions |> List.choose getOperation, opName with | [def], _ -> Some def | defs, name -> diff --git a/src/FSharp.Data.GraphQL/Planning.fs b/src/FSharp.Data.GraphQL/Planning.fs index b509ccdac..9c37b884c 100644 --- a/src/FSharp.Data.GraphQL/Planning.fs +++ b/src/FSharp.Data.GraphQL/Planning.fs @@ -1,4 +1,7 @@ -module FSharp.Data.GraphQL.Planning +/// The MIT License (MIT) +/// Copyright (c) 2016 Bazinga Technologies Inc + +module FSharp.Data.GraphQL.Planning open System open System.Reflection @@ -164,11 +167,11 @@ and private planSelection (ctx: PlanningContext) (data: PlanningData) (selection | Field field -> let identifier = field.AliasOrName if fields |> List.exists (fun f -> f.Data.Identifier.Value = identifier) - then + then fields + else let data = PlanningData.FromObject(ctx, parentDef, field) let executionPlan = plan ctx data data.Definition.Type - executionPlan::fields - else fields + fields @ [executionPlan] // unfortunatelly, order matters here | FragmentSpread spread -> let spreadName = spread.Name if !visitedFragments |> List.exists (fun name -> name = spreadName) diff --git a/src/FSharp.Data.GraphQL/Schema.fs b/src/FSharp.Data.GraphQL/Schema.fs index e7e1d7466..692f68337 100644 --- a/src/FSharp.Data.GraphQL/Schema.fs +++ b/src/FSharp.Data.GraphQL/Schema.fs @@ -10,6 +10,7 @@ open FSharp.Data.GraphQL.Parser open FSharp.Data.GraphQL.Types open FSharp.Data.GraphQL.Types.Introspection open FSharp.Data.GraphQL.Introspection +open FSharp.Data.GraphQL.Planning open FSharp.Data.GraphQL.Execution type SchemaConfig = @@ -245,6 +246,25 @@ type Schema<'Root> (query: ObjectDef<'Root>, ?mutation: ObjectDef<'Root>, ?confi return upcast NameValueLookup.ofList [ "errors", upcast [ msg ]] } + member this.CreateExecutionPlan(ast: Document, ?operationName: string): ExecutionPlan = + match findOperation ast operationName with + | Some operation -> + let rootDef = + match operation.OperationType with + | Query -> query + | Mutation -> + match mutation with + | Some m -> m + | None -> raise (GraphQLException "Operation to be executed is of type mutation, but no mutation root object was defined in current schema") + let planningCtx = { Schema = this; RootDef = rootDef; Document = ast } + planOperation planningCtx operation + | None -> raise (GraphQLException "No operation with specified name has been found for provided document") + + member this.CreateExecutionPlan(queryOrMutation: string, ?operationName: string) = + match operationName with + | None -> this.CreateExecutionPlan(parse queryOrMutation) + | Some o -> this.CreateExecutionPlan(parse queryOrMutation, o) + interface ISchema with member val TypeMap = typeMap diff --git a/src/FSharp.Data.GraphQL/TypeSystem.fs b/src/FSharp.Data.GraphQL/TypeSystem.fs index 79dbc8e57..c890d0d9f 100644 --- a/src/FSharp.Data.GraphQL/TypeSystem.fs +++ b/src/FSharp.Data.GraphQL/TypeSystem.fs @@ -662,7 +662,7 @@ and [] UnionDefinition<'In, 'Out> = override x.Equals y = match y with - | :? InterfaceDef as f -> (x :> IEquatable).Equals(f) + | :? UnionDef as f -> (x :> IEquatable).Equals(f) | _ -> false override x.GetHashCode() = diff --git a/tests/FSharp.Data.GraphQL.Tests/FSharp.Data.GraphQL.Tests.fsproj b/tests/FSharp.Data.GraphQL.Tests/FSharp.Data.GraphQL.Tests.fsproj index f133b6e2e..a8ca4efe3 100644 --- a/tests/FSharp.Data.GraphQL.Tests/FSharp.Data.GraphQL.Tests.fsproj +++ b/tests/FSharp.Data.GraphQL.Tests/FSharp.Data.GraphQL.Tests.fsproj @@ -81,6 +81,7 @@ + diff --git a/tests/FSharp.Data.GraphQL.Tests/PlanningTests.fs b/tests/FSharp.Data.GraphQL.Tests/PlanningTests.fs new file mode 100644 index 000000000..694493707 --- /dev/null +++ b/tests/FSharp.Data.GraphQL.Tests/PlanningTests.fs @@ -0,0 +1,203 @@ +/// The MIT License (MIT) +/// Copyright (c) 2016 Bazinga Technologies Inc +module FSharp.Data.GraphQL.Tests.PlanningTests + +open System +open Xunit +open FsCheck +open FSharp.Data.GraphQL +open FSharp.Data.GraphQL.Ast +open FSharp.Data.GraphQL.Types +open FSharp.Data.GraphQL.Parser +open FSharp.Data.GraphQL.Planning +open FSharp.Data.GraphQL.Execution +open FSharp.Data.GraphQL.Client.Serialization + +type Person = + { firstName : string + lastName : string + age : int } + +type Animal = + { name : string + species : string } + +type Named = + | Animal of Animal + | Person of Person + +let people = + [ { firstName = "John" + lastName = "Doe" + age = 21 } ] + +let animals = + [ { name = "Max" + species = "Dog" } ] + +let rec Person = + Define.Object + (name = "Person", + fields = [ Define.Field("firstName", String, fun _ person -> person.firstName) + Define.Field("lastName", String, fun _ person -> person.lastName) + Define.Field("age", Int, fun _ person -> person.age) + Define.Field("name", String, fun _ person -> person.firstName + " " + person.lastName) ], + interfaces = [ INamed ]) + +and Animal = + Define.Object(name = "Animal", + fields = [ Define.Field("name", String, fun _ animal -> animal.name) + Define.Field("species", String, fun _ animal -> animal.species) ], interfaces = [ INamed ]) + +and INamed = Define.Interface("INamed", [ Define.Field("name", String) ]) + +and UNamed = + Define.Union("UNamed", [ Person; Animal ], + function + | Animal a -> box a + | Person p -> upcast p) + +[] +let ``Planning should work for a simple case``() = + let schema = Schema(Person) + let query = """{ + firstName + lastName + age + }""" + let (SelectFields(data, fields)) = schema.CreateExecutionPlan(query) + equals Person (downcast data.ParentDef) + equals 3 fields.Length + fields + |> List.map (fun (ResolveValue data) -> (data.Identifier.Value, data.ParentDef, data.Definition.Type)) + |> equals [ ("firstName", upcast Person, upcast String) + ("lastName", upcast Person, upcast String) + ("age", upcast Person, upcast Int) ] + +[] +let ``Planning should work with fragments``() = + let schema = Schema(Person) + let query = """query Example { + ...named + age + } + fragment named on Person { + firstName + lastName + }""" + let (SelectFields(data, fields)) = schema.CreateExecutionPlan(query) + equals Person (downcast data.ParentDef) + equals 3 fields.Length + fields + |> List.map (fun (ResolveValue data) -> (data.Identifier.Value, data.ParentDef, data.Definition.Type)) + |> equals [ ("firstName", upcast Person, upcast String) + ("lastName", upcast Person, upcast String) + ("age", upcast Person, upcast Int) ] + +[] +let ``Planning should work with parallel fragments``() = + let schema = Schema(Person) + let query = """query Example { + ...fnamed + ...lnamed + age + } + fragment fnamed on Person { + firstName + } + fragment lnamed on Person { + lastName + } + """ + let (SelectFields(data, fields)) = schema.CreateExecutionPlan(query) + equals Person (downcast data.ParentDef) + equals 3 fields.Length + fields + |> List.map (fun (ResolveValue data) -> (data.Identifier.Value, data.ParentDef, data.Definition.Type)) + |> equals [ ("firstName", upcast Person, upcast String) + ("lastName", upcast Person, upcast String) + ("age", upcast Person, upcast Int) ] + +[] +let ``Planning should work with lists``() = + let Query = Define.Object("Query", [ Define.Field("people", ListOf Person, fun _ () -> upcast people) ]) + let schema = Schema(Query) + let query = """{ + people { + firstName + lastName + } + }""" + let (SelectFields(topData, fields)) = schema.CreateExecutionPlan(query) + equals 1 fields.Length + let (ResolveCollection(listData, SelectFields(data, innerFields))) = fields.Head + equals Person (downcast data.ParentDef) + equals 2 innerFields.Length + innerFields + |> List.map (fun (ResolveValue data) -> (data.Identifier.Value, data.ParentDef, data.Definition.Type)) + |> equals [ ("firstName", upcast Person, upcast String) + ("lastName", upcast Person, upcast String) ] + +[] +let ``Planning should work with interfaces``() = + let Query = Define.Object("Query", [ Define.Field("names", ListOf INamed, fun _ () -> upcast []) ]) + let schema = Schema(query = Query, config = { SchemaConfig.Default with Types = [ Person; Animal ] }) + let query = """query Example { + names { + name + ... on Animal { + species + } + ...ageFragment + } + } + fragment ageFragment on Person { + age + }""" + let (SelectFields(topData, fields)) = schema.CreateExecutionPlan(query) + equals 1 fields.Length + let (ResolveCollection(listData, ResolveAbstraction(data, innerFields))) = fields.Head + equals INamed (downcast data.ParentDef) + innerFields + |> Map.map + (fun typeName fields -> + fields + |> List.map (fun (ResolveValue(data)) -> (data.Identifier.Value, data.ParentDef, data.Definition.Type))) + |> equals (Map.ofList [ "Person", + [ ("name", upcast INamed, upcast String) + ("age", upcast INamed, upcast Int) ] + "Animal", + [ ("name", upcast INamed, upcast String) + ("species", upcast INamed, upcast String) ] ]) + +[] +let ``Planning should work with unions``() = + let Query = Define.Object("Query", [ Define.Field("names", ListOf UNamed, fun _ () -> upcast []) ]) + let schema = Schema(Query) + let query = """query Example { + names { + ... on Animal { + name + species + } + ... on Person { + name + age + } + } + }""" + let (SelectFields(topData, fields)) = schema.CreateExecutionPlan(query) + equals 1 fields.Length + let (ResolveCollection(listData, ResolveAbstraction(data, innerFields))) = fields.Head + equals UNamed (downcast data.ParentDef) + innerFields + |> Map.map + (fun typeName fields -> + fields + |> List.map (fun (ResolveValue(data)) -> (data.Identifier.Value, data.ParentDef, data.Definition.Type))) + |> equals (Map.ofList [ "Animal", + [ ("name", upcast UNamed, upcast String) + ("species", upcast UNamed, upcast String) ] + "Person", + [ ("name", upcast UNamed, upcast String) + ("age", upcast UNamed, upcast Int) ] ]) From 17fa6d656aeb11f7911a913c8265ff3c9b3cb91f Mon Sep 17 00:00:00 2001 From: Bartosz Sypytkowski Date: Wed, 13 Jul 2016 16:07:07 +0200 Subject: [PATCH 4/7] fixed issue with duplicate fields in plans for fragments --- src/FSharp.Data.GraphQL/Planning.fs | 38 +++++++++++++++++++---------- 1 file changed, 25 insertions(+), 13 deletions(-) diff --git a/src/FSharp.Data.GraphQL/Planning.fs b/src/FSharp.Data.GraphQL/Planning.fs index 9c37b884c..dcca653d8 100644 --- a/src/FSharp.Data.GraphQL/Planning.fs +++ b/src/FSharp.Data.GraphQL/Planning.fs @@ -74,15 +74,27 @@ type PlanningData = IsNullable = fdef.Type :? NullableDef } | None -> raise (GraphQLException (sprintf "No field '%s' was defined in object definition '%s'" field.Name parentDef.Name)) - static member FromAbstraction(ctx: PlanningContext, parentDef: AbstractDef, field: Field) : Map = + static member FromAbstraction(ctx: PlanningContext, parentDef: AbstractDef, field: Field, typeCondition: string option) : Map = let objDefs = ctx.Schema.GetPossibleTypes parentDef - objDefs - |> Array.choose (fun objDef -> - match tryFindDef ctx.Schema objDef field with - | Some fdef -> - Some (objDef.Name, { Identifier = Some field.AliasOrName; ParentDef = parentDef; Definition = fdef; Ast = field; IsNullable = fdef.Type :? NullableDef }) - | None -> None) - |> Map.ofArray + match typeCondition with + | None -> + objDefs + |> Array.choose (fun objDef -> + match tryFindDef ctx.Schema objDef field with + | Some fdef -> + Some (objDef.Name, { Identifier = Some field.AliasOrName; ParentDef = parentDef; Definition = fdef; Ast = field; IsNullable = fdef.Type :? NullableDef }) + | None -> None) + |> Map.ofArray + | Some typeName -> + match objDefs |> Array.tryFind (fun o -> o.Name = typeName) with + | Some objDef -> + match tryFindDef ctx.Schema objDef field with + | Some fdef -> + Map.ofList [ objDef.Name, { Identifier = Some field.AliasOrName; ParentDef = parentDef; Definition = fdef; Ast = field; IsNullable = fdef.Type :? NullableDef }] + | None -> Map.empty + | None -> + let pname = parentDef :?> NamedDef + raise (GraphQLException (sprintf "An abstract type '%s' has no relation with a type named '%s'" pname.Name typeName)) /// plan of reduction being a result of application of a query AST on existing schema type ExecutionPlan = @@ -156,7 +168,7 @@ let rec private plan (ctx: PlanningContext) (data: PlanningData) (typedef: TypeD | Object objDef -> planSelection ctx { data with ParentDef = objDef } data.Ast.SelectionSet (ref []) | Nullable innerDef -> plan ctx { data with IsNullable = true } innerDef | List innerDef -> planList ctx data innerDef - | Abstract abstractDef -> planAbstraction ctx { data with ParentDef = abstractDef } data.Ast.SelectionSet (ref []) + | Abstract abstractDef -> planAbstraction ctx { data with ParentDef = abstractDef } data.Ast.SelectionSet (ref []) None and private planSelection (ctx: PlanningContext) (data: PlanningData) (selectionSet: Selection list) visitedFragments : ExecutionPlan = let parentDef = downcast data.ParentDef @@ -200,14 +212,14 @@ and private planList (ctx: PlanningContext) (data: PlanningData) (innerDef: Type and private planLeaf (ctx: PlanningContext) (data: PlanningData) (leafDef: LeafDef) : ExecutionPlan = ResolveValue(data) -and private planAbstraction (ctx:PlanningContext) (data: PlanningData) (selectionSet: Selection list) visitedFragments : ExecutionPlan = +and private planAbstraction (ctx:PlanningContext) (data: PlanningData) (selectionSet: Selection list) visitedFragments typeCondition : ExecutionPlan = let parentDef = downcast data.ParentDef let plannedTypeFields = selectionSet |> List.fold(fun (fields: Map) selection -> match selection with | Field field -> - PlanningData.FromAbstraction(ctx, parentDef, field) + PlanningData.FromAbstraction(ctx, parentDef, field, typeCondition) |> Map.map (fun typeName data -> [ plan ctx data data.Definition.Type ]) |> Map.merge (fun typeName oldVal newVal -> oldVal @ newVal) fields | FragmentSpread spread -> @@ -219,13 +231,13 @@ and private planAbstraction (ctx:PlanningContext) (data: PlanningData) (selectio match ctx.Document.Definitions |> List.tryFind (function FragmentDefinition f -> f.Name.Value = spreadName | _ -> false) with | Some (FragmentDefinition fragment) -> // retrieve fragment data just as it was normal selection set - let (ResolveAbstraction(_, fragmentFields)) = planAbstraction ctx data fragment.SelectionSet visitedFragments + let (ResolveAbstraction(_, fragmentFields)) = planAbstraction ctx data fragment.SelectionSet visitedFragments fragment.TypeCondition // filter out already existing fields Map.merge (fun typeName oldVal newVal -> oldVal @ newVal) fields fragmentFields | _ -> fields | InlineFragment fragment -> // retrieve fragment data just as it was normal selection set - let (ResolveAbstraction(_, fragmentFields)) = planAbstraction ctx data fragment.SelectionSet visitedFragments + let (ResolveAbstraction(_, fragmentFields)) = planAbstraction ctx data fragment.SelectionSet visitedFragments fragment.TypeCondition // filter out already existing fields Map.merge (fun typeName oldVal newVal -> oldVal @ newVal) fields fragmentFields | _ -> fields From 72804f696c522de2aa9e67ad8f9995d4662fddb8 Mon Sep 17 00:00:00 2001 From: Bartosz Sypytkowski Date: Thu, 14 Jul 2016 16:38:28 +0200 Subject: [PATCH 5/7] wip: integration of execution plan in field resolution phase --- src/FSharp.Data.GraphQL/Execution.fs | 253 +++++++----------- src/FSharp.Data.GraphQL/Planning.fs | 159 ++++++----- src/FSharp.Data.GraphQL/Schema.fs | 30 ++- src/FSharp.Data.GraphQL/TypeSystem.fs | 102 ++++--- .../PlanningTests.fs | 54 ++-- 5 files changed, 288 insertions(+), 310 deletions(-) diff --git a/src/FSharp.Data.GraphQL/Execution.fs b/src/FSharp.Data.GraphQL/Execution.fs index 901e39a45..f3fbaf329 100644 --- a/src/FSharp.Data.GraphQL/Execution.fs +++ b/src/FSharp.Data.GraphQL/Execution.fs @@ -124,7 +124,7 @@ let private getArgumentValues (argDefs: InputFieldDef []) (args: Argument list) | value -> Map.add argdef.Name value acc | None -> collectDefaultArgValue acc argdef ) Map.empty - + let private getOperation = function | OperationDefinition odef -> Some odef | _ -> None @@ -137,15 +137,15 @@ let internal findOperation doc opName = |> List.tryFind (fun def -> def.Name = name) | _ -> None -let private coerceVariables (schema: #ISchema) (variables: VariableDefinition list) (inputs: Map option) = - match inputs with - | None -> +let private coerceVariables (schema: #ISchema) (variables: VariableDefinition list) (vars: Map) = + if vars = Map.empty + then variables |> List.filter (fun vardef -> Option.isSome vardef.DefaultValue) |> List.fold (fun acc vardef -> let variableName = vardef.VariableName Map.add variableName (coerceVariable schema vardef Map.empty) acc) Map.empty - | Some vars -> + else variables |> List.fold (fun acc vardef -> let variableName = vardef.VariableName @@ -165,78 +165,6 @@ let private shouldSkip (ctx: ExecutionContext) (directive: Directive) = | "skip" when not <| coerceDirectiveValue ctx directive -> false | "include" when coerceDirectiveValue ctx directive -> false | _ -> true - -let private doesFragmentTypeApply (ctx: ExecutionContext) fragment (objectType: ObjectDef) = - match fragment.TypeCondition with - | None -> true - | Some typeCondition -> - match ctx.Schema.TryFindType typeCondition with - | None -> false - | Some conditionalType when conditionalType.Name = objectType.Name -> true - | Some (Abstract conditionalType) -> ctx.Schema.IsPossibleType conditionalType objectType - | _ -> false - -// 6.5 Evaluating selection sets -let rec private collectFields (ctx: ExecutionContext) typedef (selectionSet: Selection list) (visitedFragments): (string * Field []) [] = - let rec findGroupIndexByName (groupedFields: System.Collections.Generic.List) (name: string) (i: int) : int = - if i < 0 - then -1 - else - let (k, _) = groupedFields.[i] - if k = name then i - else findGroupIndexByName groupedFields name (i-1) - - let groupedFields = System.Collections.Generic.List(selectionSet.Length) - selectionSet - |> List.iteri(fun i selection -> - if not (List.exists (shouldSkip ctx) selection.Directives) - then - match selection with - | Field field -> - let name = field.AliasOrName - match findGroupIndexByName groupedFields name (groupedFields.Count-1) with - | -1 -> - groupedFields.Add (name, [| field |]) - | idx -> - let (_, value) = groupedFields.[idx] - groupedFields.[idx] <- (name, Array.append [| field |] value) - | FragmentSpread spread -> - let fragmentSpreadName = spread.Name - if not (List.exists (fun fragmentName -> fragmentName = fragmentSpreadName) !visitedFragments) - then - visitedFragments := (fragmentSpreadName::!visitedFragments) - let found = - ctx.Document.Definitions - |> List.tryFind (function FragmentDefinition f when f.Name.Value = fragmentSpreadName -> true | _ -> false) - match found with - | Some (FragmentDefinition fragment) -> - if doesFragmentTypeApply ctx fragment typedef - then - let fragmentSelectionSet = fragment.SelectionSet - let fragmentGroupedFieldSet = collectFields ctx typedef fragmentSelectionSet visitedFragments - for j = 0 to fragmentGroupedFieldSet.Length - 1 do - let (responseKey, fragmentGroup) = fragmentGroupedFieldSet.[j] - match findGroupIndexByName groupedFields responseKey (groupedFields.Count-1) with - | -1 -> - groupedFields.Add (responseKey, fragmentGroup) - | idx -> - let (_, value) = groupedFields.[idx] - groupedFields.[idx] <- (responseKey, Array.append fragmentGroup value) - | _ -> () - | InlineFragment fragment -> - if doesFragmentTypeApply ctx fragment typedef - then - let fragmentSelectionSet = fragment.SelectionSet - let fragmentGroupedFieldSet = collectFields ctx typedef fragmentSelectionSet visitedFragments - for j = 0 to fragmentGroupedFieldSet.Length - 1 do - let (responseKey, fragmentGroup) = fragmentGroupedFieldSet.[j] - match findGroupIndexByName groupedFields responseKey (groupedFields.Count-1) with - | -1 -> - groupedFields.Add (responseKey, fragmentGroup) - | idx -> - let (_, value) = groupedFields.[idx] - groupedFields.[idx] <- (responseKey, Array.append fragmentGroup value)) - groupedFields.ToArray() let private defaultResolveType possibleTypesFn abstractDef : obj -> ObjectDef = let possibleTypes = possibleTypesFn abstractDef @@ -289,7 +217,7 @@ let TypeNameMetaFieldDef : FieldDef = Define.Field( let rec createCompletion (possibleTypesFn: TypeDef -> ObjectDef []) (returnDef: OutputDef): ResolveFieldContext -> obj -> Job = match returnDef with - | Object objdef -> createObjectCompletion objdef + | Object objdef -> executePlanInfo objdef | Scalar scalardef -> let (coerce: obj -> obj option) = scalardef.CoerceValue fun _ value -> @@ -311,7 +239,7 @@ let rec createCompletion (possibleTypesFn: TypeDef -> ObjectDef []) (returnDef: |> Job.conCollect return completed.ToArray() :> obj | _ -> return raise ( - GraphQLException (sprintf "Expected to have enumerable value in field '%s' but got '%O'" ctx.FieldName (value.GetType()))) + GraphQLException (sprintf "Expected to have enumerable value in field '%s' but got '%O'" ctx.ExecutionPlan.Data.Identifier (value.GetType()))) } | Nullable (Output innerdef) -> let innerfn = createCompletion possibleTypesFn innerdef @@ -327,29 +255,20 @@ let rec createCompletion (possibleTypesFn: TypeDef -> ObjectDef []) (returnDef: | Interface idef -> let resolver = resolveInterfaceType possibleTypesFn idef fun ctx value -> job { - let resolved = resolver value - return! createObjectCompletion resolved ctx value + let resolvedDef = resolver value + return! executePlanInfo resolvedDef ctx value } | Union udef -> let resolver = resolveUnionType possibleTypesFn udef fun ctx value -> job { - let resolved = resolver value - return! createObjectCompletion resolved ctx (udef.ResolveValue value) + let resolvedDef = resolver value + return! executePlanInfo resolvedDef ctx (udef.ResolveValue value) } | Enum _ -> fun _ value -> let result = coerceStringValue value Job.result (result |> Option.map box |> Option.toObj) -and private createObjectCompletion objdef = - fun (ctx: ResolveFieldContext) value -> job { - let groupedFieldSet = - ctx.Fields - |> Array.fold (fun _ field -> collectFields ctx.ExecutionContext objdef field.SelectionSet (ref [])) [||] - let! res = executeFields ctx.ExecutionContext objdef value groupedFieldSet - return res :> obj } - - and private compileField possibleTypesFn (fieldDef: FieldDef) : ExecuteField = let completed = createCompletion possibleTypesFn (fieldDef.Type) let resolve = fieldDef.Resolve @@ -372,53 +291,84 @@ and private getFieldDefinition (ctx: ExecutionContext) (objectType: ObjectDef) ( | "__type" when Object.ReferenceEquals(ctx.Schema.Query, objectType) -> Some (upcast TypeMetaFieldDef) | "__typename" -> Some (upcast TypeNameMetaFieldDef) | fieldName -> objectType.Fields |> Map.tryFind fieldName + +and private createFieldContext objdef ctx (info: ExecutionPlanInfo) = + let data = info.Data + let fdef = data.Definition + let args = getArgumentValues fdef.Args data.Ast.Arguments ctx.Variables + { ExecutionPlan = info + Context = ctx.Context + ReturnType = fdef.Type + ParentType = objdef + Schema = ctx.Schema + Args = args + Variables = ctx.Variables } -and private getFieldEntry (ctx: ExecutionContext) typedef value (fields: Field []) : Job = - let firstField = fields.[0] - match getFieldDefinition ctx typedef firstField with - | None -> Job.result null - | Some fieldDef -> - let args = getArgumentValues fieldDef.Args firstField.Arguments ctx.Variables - let resolveFieldCtx = { - FieldName = fieldDef.Name - Fields = fields - FieldType = fieldDef - ReturnType = fieldDef.Type - ParentType = typedef - Schema = ctx.Schema - Args = args - Operation = ctx.Operation - Fragments = ctx.Fragments - Variables = ctx.Variables - AddError = ctx.Errors.Add - ExecutionContext = ctx - } - fieldDef.Execute resolveFieldCtx value +and executePlanInfo (objdef: ObjectDef) ctx value : Job = + match ctx.ExecutionPlan with + | ResolveValue data -> data.Definition.Execute ctx value + | SelectFields(data, fieldInfos) -> + let nestedValue = data.Definition.Execute ctx value + executeFields objdef ctx nestedValue fieldInfos + | ResolveCollection(data, info) -> + let innerCtx = createFieldContext objdef ctx info + data.Definition.Execute innerCtx value + | ResolveAbstraction(data, typeFields) -> + match Map.tryFind objdef.Name typeFields with + | Some fieldInfos -> + let nestedValue = data.Definition.Execute ctx value + executeFields objdef ctx nestedValue fieldInfos + | None -> + let (Named named) = data.ParentDef + Job.raises (GraphQLException (sprintf "Type '%s' cannot abstract over type '%s'" named.Name objdef.Name)) -and private executeFields (ctx: ExecutionContext) (typedef: ObjectDef) (value: obj) (groupedFieldSet: (string * Field []) []) : Job = job { - let result = - groupedFieldSet +and executeFields (objdef: ObjectDef) (ctx: ResolveFieldContext) value fieldInfos = job { + let resultSet = + fieldInfos + |> List.filter (fun info -> info.Data.Include ctx.Variables) + |> List.map (fun info -> (info.Data.Identifier, info)) + |> List.toArray + let result = + resultSet |> Array.map fst - |> NameValueLookup - do! groupedFieldSet - |> Array.map (fun (responseKey, fields) -> job { - let! res = getFieldEntry ctx typedef value fields - do result.Update responseKey res }) + |> NameValueLookup + do! resultSet + |> Array.map (fun (name, info) -> job { + let innerCtx = createFieldContext objdef ctx info + let! res = executePlanInfo objdef innerCtx value + do result.Update name res }) |> Job.conIgnore - return result } + return box result } -and private executeFieldsSync ctx typedef value (groupedFieldSet: (string * Field []) []) = job { - let result = - groupedFieldSet +let executePlan (ctx: ExecutionContext) (plan: ExecutionPlan) (objdef: ObjectDef) value = job { + let resultSet = + plan.Fields + |> List.filter (fun info -> info.Data.Include ctx.Variables) + |> List.map (fun info -> (info.Data.Identifier, info)) + |> List.toArray + let result = + resultSet |> Array.map fst - |> NameValueLookup - do! groupedFieldSet - |> Array.map (fun (responseKey, fields) -> job { - let! entry = getFieldEntry ctx typedef value fields - result.Update responseKey entry - }) - |> Job.seqIgnore - return result } + |> NameValueLookup + do! resultSet + |> Array.map (fun (name, info) -> job { + let data = info.Data + let fdef = data.Definition + let args = getArgumentValues fdef.Args data.Ast.Arguments ctx.Variables + let fieldCtx = + { ExecutionPlan = info + Context = ctx + ReturnType = fdef.Type + ParentType = objdef + Schema = ctx.Schema + Args = args + Variables = ctx.Variables } + let! res = executePlanInfo objdef fieldCtx value + do result.Update name res }) + |> match plan.Strategy with + | Parallel -> Job.conIgnore + | Serial -> Job.seqIgnore + return box result } let private compileInputObject (indef: InputObjectDef) = indef.Fields @@ -443,31 +393,18 @@ let internal compileSchema possibleTypesFn types = | InputObject indef -> compileInputObject indef | _ -> ()) -let private evaluate (schema: #ISchema) doc operation variables root errors = job { - let variables = coerceVariables schema operation.VariableDefinitions variables - let ctx = { - Schema = schema - RootValue = match root with None -> null | Some x -> x - Document = doc - Variables = variables - Operation = operation - Fragments = doc.Definitions |> List.choose (fun x -> match x with FragmentDefinition f -> Some f | _ -> None) - Errors = errors - } - match operation.OperationType with - | Mutation -> - let groupedFieldSet = - collectFields ctx schema.Mutation.Value operation.SelectionSet (ref []) - return! executeFieldsSync ctx schema.Mutation.Value ctx.RootValue groupedFieldSet - | Query -> - let groupedFieldSet = - collectFields ctx schema.Query operation.SelectionSet (ref []) - return! executeFields ctx schema.Query ctx.RootValue groupedFieldSet } - -let internal execute (schema: #ISchema) doc operationName variables root errors = async { - match findOperation doc operationName with - | Some operation -> return! evaluate schema doc operation variables root errors |> Async.Global.ofJob - | None -> return raise (GraphQLException "No operation with specified name has been found for provided document") } +let internal evaluate (schema: #ISchema) (executionPlan: ExecutionPlan) (variables: Map) (root: obj) errors = + job { + let variables = coerceVariables schema executionPlan.Operation.VariableDefinitions variables + let operation = executionPlan.Operation + let ctx = { + Schema = schema + ExecutionPlan = executionPlan + RootValue = root + Variables = variables + Errors = errors } + return! executePlan ctx executionPlan schema.Query root + } |> Async.Global.ofJob // we don't need to know possible types at this point SchemaMetaFieldDef.Execute <- compileField Unchecked.defaultof ObjectDef[]> SchemaMetaFieldDef diff --git a/src/FSharp.Data.GraphQL/Planning.fs b/src/FSharp.Data.GraphQL/Planning.fs index dcca653d8..ebdc6b889 100644 --- a/src/FSharp.Data.GraphQL/Planning.fs +++ b/src/FSharp.Data.GraphQL/Planning.fs @@ -47,73 +47,6 @@ let private tryFindDef (schema: ISchema) (objdef: ObjectDef) (field: Field) : Fi | "__typename" -> Some (upcast TypeNameMetaFieldDef) | fieldName -> objdef.Fields |> Map.tryFind fieldName -type PlanningContext = - { Schema: ISchema - RootDef: ObjectDef - Document: Document } - -type Includer = Map -> bool -type PlanningData = - { /// Field identifier, which may be either field name or alias. For top level execution plan it will be None. - Identifier: string option - /// Composite definition being the parent of the current field, execution plan refers to. - ParentDef: CompositeDef - /// Field definition of corresponding type found in current schema. - Definition: FieldDef - /// Boolean value marking if null values are allowed. - IsNullable: bool - /// AST node of the parsed query document. - Ast: Field } - static member FromObject(ctx: PlanningContext, parentDef: ObjectDef, field: Field) : PlanningData = - match tryFindDef ctx.Schema parentDef field with - | Some fdef -> - { Identifier = Some field.AliasOrName - ParentDef = parentDef - Definition = fdef - Ast = field - IsNullable = fdef.Type :? NullableDef } - | None -> - raise (GraphQLException (sprintf "No field '%s' was defined in object definition '%s'" field.Name parentDef.Name)) - static member FromAbstraction(ctx: PlanningContext, parentDef: AbstractDef, field: Field, typeCondition: string option) : Map = - let objDefs = ctx.Schema.GetPossibleTypes parentDef - match typeCondition with - | None -> - objDefs - |> Array.choose (fun objDef -> - match tryFindDef ctx.Schema objDef field with - | Some fdef -> - Some (objDef.Name, { Identifier = Some field.AliasOrName; ParentDef = parentDef; Definition = fdef; Ast = field; IsNullable = fdef.Type :? NullableDef }) - | None -> None) - |> Map.ofArray - | Some typeName -> - match objDefs |> Array.tryFind (fun o -> o.Name = typeName) with - | Some objDef -> - match tryFindDef ctx.Schema objDef field with - | Some fdef -> - Map.ofList [ objDef.Name, { Identifier = Some field.AliasOrName; ParentDef = parentDef; Definition = fdef; Ast = field; IsNullable = fdef.Type :? NullableDef }] - | None -> Map.empty - | None -> - let pname = parentDef :?> NamedDef - raise (GraphQLException (sprintf "An abstract type '%s' has no relation with a type named '%s'" pname.Name typeName)) - -/// plan of reduction being a result of application of a query AST on existing schema -type ExecutionPlan = - // reducer for scalar or enum - | ResolveValue of data:PlanningData - // reducer for selection set applied upon output object - | SelectFields of data:PlanningData * fields:ExecutionPlan list - // reducer for each of the collection elements - | ResolveCollection of data:PlanningData * elementPlan:ExecutionPlan - // reducer for union and interface types to be resolved into ReduceSelection at runtime - | ResolveAbstraction of data:PlanningData * typeFields:Map - member x.Data = - match x with - | ResolveValue(data) -> data - | SelectFields(data, _) -> data - | ResolveCollection(data, _) -> data - | ResolveAbstraction(data, _) -> data - - let private coerceVariables (schema: #ISchema) (variables: VariableDefinition list) (inputs: Map option) = match inputs with | None -> @@ -127,6 +60,54 @@ let private coerceVariables (schema: #ISchema) (variables: VariableDefinition li |> List.fold (fun acc vardef -> let variableName = vardef.VariableName Map.add variableName (coerceVariable schema vardef vars) acc) Map.empty + +let objectData(ctx: PlanningContext, parentDef: ObjectDef, field: Field, includer: Includer) : PlanningData = + match tryFindDef ctx.Schema parentDef field with + | Some fdef -> + { Identifier = field.AliasOrName + ParentDef = parentDef + Definition = fdef + Ast = field + IsNullable = fdef.Type :? NullableDef + Include = includer } + | None -> + raise (GraphQLException (sprintf "No field '%s' was defined in object definition '%s'" field.Name parentDef.Name)) + +let abstractionData(ctx: PlanningContext, parentDef: AbstractDef, field: Field, typeCondition: string option, includer: Includer) : Map = + let objDefs = ctx.Schema.GetPossibleTypes parentDef + match typeCondition with + | None -> + objDefs + |> Array.choose (fun objDef -> + match tryFindDef ctx.Schema objDef field with + | Some fdef -> + let data = + { Identifier = field.AliasOrName + ParentDef = parentDef + Definition = fdef + Ast = field + IsNullable = fdef.Type :? NullableDef + Include = includer } + Some (objDef.Name, data) + | None -> None) + |> Map.ofArray + | Some typeName -> + match objDefs |> Array.tryFind (fun o -> o.Name = typeName) with + | Some objDef -> + match tryFindDef ctx.Schema objDef field with + | Some fdef -> + let data = + { Identifier = field.AliasOrName + ParentDef = parentDef + Definition = fdef + Ast = field + IsNullable = fdef.Type :? NullableDef + Include = includer } + Map.ofList [ objDef.Name, data ] + | None -> Map.empty + | None -> + let pname = parentDef :?> NamedDef + raise (GraphQLException (sprintf "An abstract type '%s' has no relation with a type named '%s'" pname.Name typeName)) let private directiveIncluder (directive: Directive) : Includer = fun variables -> @@ -162,7 +143,7 @@ let private doesFragmentTypeApply (schema: ISchema) fragment (objectType: Object | Some (Abstract conditionalType) -> schema.IsPossibleType conditionalType objectType | _ -> false -let rec private plan (ctx: PlanningContext) (data: PlanningData) (typedef: TypeDef) : ExecutionPlan = +let rec private plan (ctx: PlanningContext) (data: PlanningData) (typedef: TypeDef) : ExecutionPlanInfo = match typedef with | Leaf leafDef -> planLeaf ctx data leafDef | Object objDef -> planSelection ctx { data with ParentDef = objDef } data.Ast.SelectionSet (ref []) @@ -170,18 +151,19 @@ let rec private plan (ctx: PlanningContext) (data: PlanningData) (typedef: TypeD | List innerDef -> planList ctx data innerDef | Abstract abstractDef -> planAbstraction ctx { data with ParentDef = abstractDef } data.Ast.SelectionSet (ref []) None -and private planSelection (ctx: PlanningContext) (data: PlanningData) (selectionSet: Selection list) visitedFragments : ExecutionPlan = +and private planSelection (ctx: PlanningContext) (data: PlanningData) (selectionSet: Selection list) visitedFragments : ExecutionPlanInfo = let parentDef = downcast data.ParentDef let plannedFields = selectionSet - |> List.fold(fun (fields: ExecutionPlan list) selection -> + |> List.fold(fun (fields: ExecutionPlanInfo list) selection -> + let includer = getIncluder selection.Directives match selection with | Field field -> let identifier = field.AliasOrName - if fields |> List.exists (fun f -> f.Data.Identifier.Value = identifier) + if fields |> List.exists (fun f -> f.Data.Identifier = identifier) then fields else - let data = PlanningData.FromObject(ctx, parentDef, field) + let data = objectData(ctx, parentDef, field, includer) let executionPlan = plan ctx data data.Definition.Type fields @ [executionPlan] // unfortunatelly, order matters here | FragmentSpread spread -> @@ -206,20 +188,21 @@ and private planSelection (ctx: PlanningContext) (data: PlanningData) (selection ) [] SelectFields(data, plannedFields) -and private planList (ctx: PlanningContext) (data: PlanningData) (innerDef: TypeDef) : ExecutionPlan = +and private planList (ctx: PlanningContext) (data: PlanningData) (innerDef: TypeDef) : ExecutionPlanInfo = ResolveCollection(data, plan ctx data innerDef) -and private planLeaf (ctx: PlanningContext) (data: PlanningData) (leafDef: LeafDef) : ExecutionPlan = +and private planLeaf (ctx: PlanningContext) (data: PlanningData) (leafDef: LeafDef) : ExecutionPlanInfo = ResolveValue(data) -and private planAbstraction (ctx:PlanningContext) (data: PlanningData) (selectionSet: Selection list) visitedFragments typeCondition : ExecutionPlan = +and private planAbstraction (ctx:PlanningContext) (data: PlanningData) (selectionSet: Selection list) visitedFragments typeCondition : ExecutionPlanInfo = let parentDef = downcast data.ParentDef let plannedTypeFields = selectionSet - |> List.fold(fun (fields: Map) selection -> + |> List.fold(fun (fields: Map) selection -> + let includer = getIncluder selection.Directives match selection with | Field field -> - PlanningData.FromAbstraction(ctx, parentDef, field, typeCondition) + abstractionData(ctx, parentDef, field, typeCondition, includer) |> Map.map (fun typeName data -> [ plan ctx data data.Definition.Type ]) |> Map.merge (fun typeName oldVal newVal -> oldVal @ newVal) fields | FragmentSpread spread -> @@ -246,9 +229,25 @@ and private planAbstraction (ctx:PlanningContext) (data: PlanningData) (selectio let planOperation (ctx: PlanningContext) (operation: OperationDefinition) : ExecutionPlan = let data = { - Identifier = None; + Identifier = null; Ast = Unchecked.defaultof IsNullable = false ParentDef = ctx.RootDef - Definition = Unchecked.defaultof} - planSelection ctx data operation.SelectionSet (ref []) \ No newline at end of file + Definition = Unchecked.defaultof + Include = incl } + let (SelectFields(_, topFields)) = planSelection ctx data operation.SelectionSet (ref []) + match operation.OperationType with + | Query -> + { Operation = operation + Fields = topFields + RootDef = ctx.Schema.Query + Strategy = Parallel } + | Mutation -> + match ctx.Schema.Mutation with + | Some mutationDef -> + { Operation = operation + Fields = topFields + RootDef = mutationDef + Strategy = Serial } + | None -> + raise (GraphQLException "Tried to execute a GraphQL mutation on schema with no mutation type defined") \ No newline at end of file diff --git a/src/FSharp.Data.GraphQL/Schema.fs b/src/FSharp.Data.GraphQL/Schema.fs index 692f68337..463d67e02 100644 --- a/src/FSharp.Data.GraphQL/Schema.fs +++ b/src/FSharp.Data.GraphQL/Schema.fs @@ -220,24 +220,26 @@ type Schema<'Root> (query: ObjectDef<'Root>, ?mutation: ObjectDef<'Root>, ?confi compileSchema getPossibleTypes typeMap member this.AsyncExecute(ast: Document, ?data: 'Root, ?variables: Map, ?operationName: string): Async> = - async { - try - let errors = System.Collections.Concurrent.ConcurrentBag() - let! result = execute this ast operationName variables (data |> Option.map box) errors - let output = [ "data", box result ] @ if errors.IsEmpty then [] else [ "errors", upcast (errors.ToArray() |> Array.map (fun e -> e.Message)) ] - return upcast NameValueLookup.ofList output - with - | ex -> - let msg = ex.ToString() - return upcast NameValueLookup.ofList [ "errors", upcast [ msg ]] - } + let executionPlan = + match operationName with + | Some opname -> this.CreateExecutionPlan(ast, opname) + | None -> this.CreateExecutionPlan(ast) + this.AsyncEvaluate(executionPlan, data, defaultArg variables Map.empty) member this.AsyncExecute(queryOrMutation: string, ?data: 'Root, ?variables: Map, ?operationName: string): Async> = + let ast = parse queryOrMutation + let executionPlan = + match operationName with + | Some opname -> this.CreateExecutionPlan(ast, opname) + | None -> this.CreateExecutionPlan(ast) + this.AsyncEvaluate(executionPlan, data, defaultArg variables Map.empty) + + member this.AsyncEvaluate(executionPlan: ExecutionPlan, data: 'Root option, variables: Map): Async> = async { try - let ast = parse queryOrMutation - let errors = System.Collections.Concurrent.ConcurrentBag() - let! result = execute this ast operationName variables (data |> Option.map box) errors + let errors = System.Collections.Concurrent.ConcurrentBag() + let rootObj = data |> Option.map box |> Option.toObj + let! result = evaluate this executionPlan variables rootObj errors let output = [ "data", box result ] @ if errors.IsEmpty then [] else [ "errors", upcast (errors.ToArray() |> Array.map (fun e -> e.Message)) ] return upcast NameValueLookup.ofList output with diff --git a/src/FSharp.Data.GraphQL/TypeSystem.fs b/src/FSharp.Data.GraphQL/TypeSystem.fs index c890d0d9f..e262c6b3d 100644 --- a/src/FSharp.Data.GraphQL/TypeSystem.fs +++ b/src/FSharp.Data.GraphQL/TypeSystem.fs @@ -217,6 +217,77 @@ and NamedDef = abstract Name : string end +and PlanningContext = + { Schema: ISchema + RootDef: ObjectDef + Document: Document } + +and Includer = Map -> bool + +and PlanningData = + { /// Field identifier, which may be either field name or alias. For top level execution plan it will be None. + Identifier: string + /// Composite definition being the parent of the current field, execution plan refers to. + ParentDef: CompositeDef + /// Field definition of corresponding type found in current schema. + Definition: FieldDef + /// Boolean value marking if null values are allowed. + IsNullable: bool + /// AST node of the parsed query document. + Ast: Field + // logic describing if correlated field should be included in result set + Include : Includer } + +/// plan of reduction being a result of application of a query AST on existing schema +and ExecutionPlanInfo = + // reducer for scalar or enum + | ResolveValue of data:PlanningData + // reducer for selection set applied upon output object + | SelectFields of data:PlanningData * fields:ExecutionPlanInfo list + // reducer for each of the collection elements + | ResolveCollection of data:PlanningData * elementPlan:ExecutionPlanInfo + // reducer for union and interface types to be resolved into ReduceSelection at runtime + | ResolveAbstraction of data:PlanningData * typeFields:Map + member x.Data = + match x with + | ResolveValue(data) -> data + | SelectFields(data, _) -> data + | ResolveCollection(data, _) -> data + | ResolveAbstraction(data, _) -> data + +and ExecutionStrategy = + | Serial + | Parallel + +and ExecutionPlan = + { Operation: OperationDefinition + RootDef: ObjectDef + Strategy: ExecutionStrategy + Fields: ExecutionPlanInfo list } + +and ExecutionContext = + { Schema: ISchema + RootValue: obj + ExecutionPlan: ExecutionPlan + Variables: Map + Errors: ConcurrentBag } + +and ResolveFieldContext = + { ExecutionPlan : ExecutionPlanInfo + Context: ExecutionContext + ReturnType : TypeDef + ParentType : ObjectDef + Schema : ISchema + Args : Map + Variables : Map } + member x.AddError (error: exn) = x.Context.Errors.Add error + member x.TryArg(name : string) : 't option = + match Map.tryFind name x.Args with + | Some o -> Some(o :?> 't) + | None -> None + member x.Arg(name : string) : 't = + downcast Map.find name x.Args + and ExecuteField = ResolveFieldContext -> obj -> Job and FieldDef = interface @@ -236,37 +307,6 @@ and FieldDef<'Val> = inherit FieldDef end -and ExecutionContext = - { - Schema: ISchema - RootValue: obj - Document: Document - Operation: OperationDefinition - Fragments: FragmentDefinition list - Variables: Map - Errors: ConcurrentBag - } - -and ResolveFieldContext = - { FieldName : string - Fields : Field [] - FieldType : FieldDef - ReturnType : TypeDef - ParentType : ObjectDef - Schema : ISchema - Args : Map - Operation : OperationDefinition - Fragments : FragmentDefinition list - Variables : Map - ExecutionContext: ExecutionContext - AddError: exn -> unit } - member x.TryArg(name : string) : 't option = - match Map.tryFind name x.Args with - | Some o -> Some(o :?> 't) - | None -> None - member x.Arg(name : string) : 't = - downcast Map.find name x.Args - and ScalarDef = interface abstract Name : string diff --git a/tests/FSharp.Data.GraphQL.Tests/PlanningTests.fs b/tests/FSharp.Data.GraphQL.Tests/PlanningTests.fs index 694493707..1891245d2 100644 --- a/tests/FSharp.Data.GraphQL.Tests/PlanningTests.fs +++ b/tests/FSharp.Data.GraphQL.Tests/PlanningTests.fs @@ -65,11 +65,11 @@ let ``Planning should work for a simple case``() = lastName age }""" - let (SelectFields(data, fields)) = schema.CreateExecutionPlan(query) - equals Person (downcast data.ParentDef) - equals 3 fields.Length - fields - |> List.map (fun (ResolveValue data) -> (data.Identifier.Value, data.ParentDef, data.Definition.Type)) + let plan = schema.CreateExecutionPlan(query) + plan.RootDef |> equals (upcast Person) + equals 3 plan.Fields.Length + plan.Fields + |> List.map (fun (ResolveValue data) -> (data.Identifier, data.ParentDef, data.Definition.Type)) |> equals [ ("firstName", upcast Person, upcast String) ("lastName", upcast Person, upcast String) ("age", upcast Person, upcast Int) ] @@ -85,11 +85,11 @@ let ``Planning should work with fragments``() = firstName lastName }""" - let (SelectFields(data, fields)) = schema.CreateExecutionPlan(query) - equals Person (downcast data.ParentDef) - equals 3 fields.Length - fields - |> List.map (fun (ResolveValue data) -> (data.Identifier.Value, data.ParentDef, data.Definition.Type)) + let plan = schema.CreateExecutionPlan(query) + plan.RootDef |> equals (upcast Person) + equals 3 plan.Fields.Length + plan.Fields + |> List.map (fun (ResolveValue data) -> (data.Identifier, data.ParentDef, data.Definition.Type)) |> equals [ ("firstName", upcast Person, upcast String) ("lastName", upcast Person, upcast String) ("age", upcast Person, upcast Int) ] @@ -109,11 +109,11 @@ let ``Planning should work with parallel fragments``() = lastName } """ - let (SelectFields(data, fields)) = schema.CreateExecutionPlan(query) - equals Person (downcast data.ParentDef) - equals 3 fields.Length - fields - |> List.map (fun (ResolveValue data) -> (data.Identifier.Value, data.ParentDef, data.Definition.Type)) + let plan = schema.CreateExecutionPlan(query) + plan.RootDef |> equals (upcast Person) + equals 3 plan.Fields.Length + plan.Fields + |> List.map (fun (ResolveValue data) -> (data.Identifier, data.ParentDef, data.Definition.Type)) |> equals [ ("firstName", upcast Person, upcast String) ("lastName", upcast Person, upcast String) ("age", upcast Person, upcast Int) ] @@ -128,13 +128,13 @@ let ``Planning should work with lists``() = lastName } }""" - let (SelectFields(topData, fields)) = schema.CreateExecutionPlan(query) - equals 1 fields.Length - let (ResolveCollection(listData, SelectFields(data, innerFields))) = fields.Head + let plan = schema.CreateExecutionPlan(query) + equals 1 plan.Fields.Length + let (ResolveCollection(listData, SelectFields(data, innerFields))) = plan.Fields.Head equals Person (downcast data.ParentDef) equals 2 innerFields.Length innerFields - |> List.map (fun (ResolveValue data) -> (data.Identifier.Value, data.ParentDef, data.Definition.Type)) + |> List.map (fun (ResolveValue data) -> (data.Identifier, data.ParentDef, data.Definition.Type)) |> equals [ ("firstName", upcast Person, upcast String) ("lastName", upcast Person, upcast String) ] @@ -154,15 +154,15 @@ let ``Planning should work with interfaces``() = fragment ageFragment on Person { age }""" - let (SelectFields(topData, fields)) = schema.CreateExecutionPlan(query) - equals 1 fields.Length - let (ResolveCollection(listData, ResolveAbstraction(data, innerFields))) = fields.Head + let plan = schema.CreateExecutionPlan(query) + equals 1 plan.Fields.Length + let (ResolveCollection(listData, ResolveAbstraction(data, innerFields))) = plan.Fields.Head equals INamed (downcast data.ParentDef) innerFields |> Map.map (fun typeName fields -> fields - |> List.map (fun (ResolveValue(data)) -> (data.Identifier.Value, data.ParentDef, data.Definition.Type))) + |> List.map (fun (ResolveValue(data)) -> (data.Identifier, data.ParentDef, data.Definition.Type))) |> equals (Map.ofList [ "Person", [ ("name", upcast INamed, upcast String) ("age", upcast INamed, upcast Int) ] @@ -186,15 +186,15 @@ let ``Planning should work with unions``() = } } }""" - let (SelectFields(topData, fields)) = schema.CreateExecutionPlan(query) - equals 1 fields.Length - let (ResolveCollection(listData, ResolveAbstraction(data, innerFields))) = fields.Head + let plan = schema.CreateExecutionPlan(query) + equals 1 plan.Fields.Length + let (ResolveCollection(listData, ResolveAbstraction(data, innerFields))) = plan.Fields.Head equals UNamed (downcast data.ParentDef) innerFields |> Map.map (fun typeName fields -> fields - |> List.map (fun (ResolveValue(data)) -> (data.Identifier.Value, data.ParentDef, data.Definition.Type))) + |> List.map (fun (ResolveValue(data)) -> (data.Identifier, data.ParentDef, data.Definition.Type))) |> equals (Map.ofList [ "Animal", [ ("name", upcast UNamed, upcast String) ("species", upcast UNamed, upcast String) ] From 853848d9c828dba2411ed512c3bdc76abf8047d7 Mon Sep 17 00:00:00 2001 From: Bartosz Sypytkowski Date: Fri, 15 Jul 2016 14:56:58 +0200 Subject: [PATCH 6/7] wip: remaining bugs - skip/include on fragments, weird abstract value resolution (should be working) --- src/FSharp.Data.GraphQL/Execution.fs | 87 ++++---------- src/FSharp.Data.GraphQL/Planning.fs | 1 + src/FSharp.Data.GraphQL/Schema.fs | 9 ++ .../ExecutionBenchmark.fs | 106 ++++++++++++------ .../ExecutionTests.fs | 5 +- 5 files changed, 106 insertions(+), 102 deletions(-) diff --git a/src/FSharp.Data.GraphQL/Execution.fs b/src/FSharp.Data.GraphQL/Execution.fs index f3fbaf329..1119b7134 100644 --- a/src/FSharp.Data.GraphQL/Execution.fs +++ b/src/FSharp.Data.GraphQL/Execution.fs @@ -11,6 +11,7 @@ open Hopac open Hopac.Extensions open FSharp.Data.GraphQL.Ast open FSharp.Data.GraphQL.Types +open FSharp.Data.GraphQL.Planning open FSharp.Data.GraphQL.Types.Introspection open FSharp.Data.GraphQL.Introspection @@ -186,38 +187,13 @@ let resolveUnionType possibleTypesFn (uniondef: UnionDef) = match uniondef.ResolveType with | Some resolveType -> resolveType | None -> defaultResolveType possibleTypesFn uniondef - -let SchemaMetaFieldDef = Define.Field( - name = "__schema", - description = "Access the current type schema of this server.", - typedef = __Schema, - resolve = fun ctx (_: obj) -> ctx.Schema.Introspected) - -let TypeMetaFieldDef = Define.Field( - name = "__type", - description = "Request the type information of a single type.", - typedef = __Type, - args = [ - { Name = "name" - Description = None - Type = String - DefaultValue = None - ExecuteInput = variableOrElse(coerceStringInput >> Option.map box >> Option.toObj) } - ], - resolve = fun ctx (_:obj) -> - ctx.Schema.Introspected.Types - |> Seq.find (fun t -> t.Name = ctx.Arg("name")) - |> IntrospectionTypeRef.Named) - -let TypeNameMetaFieldDef : FieldDef = Define.Field( - name = "__typename", - description = "The name of the current Object type at runtime.", - typedef = String, - resolve = fun ctx (_:obj) -> ctx.ParentType.Name) - + let rec createCompletion (possibleTypesFn: TypeDef -> ObjectDef []) (returnDef: OutputDef): ResolveFieldContext -> obj -> Job = match returnDef with - | Object objdef -> executePlanInfo objdef + | Object objdef -> + fun (ctx: ResolveFieldContext) value -> + let (SelectFields(_, fields)) = ctx.ExecutionPlan + executeFields objdef ctx value fields | Scalar scalardef -> let (coerce: obj -> obj option) = scalardef.CoerceValue fun _ value -> @@ -227,15 +203,17 @@ let rec createCompletion (possibleTypesFn: TypeDef -> ObjectDef []) (returnDef: | List (Output innerdef) -> let (innerfn: ResolveFieldContext -> obj -> Job) = createCompletion possibleTypesFn innerdef fun ctx (value: obj) -> job { + let (ResolveCollection(_,innerPlan)) = ctx.ExecutionPlan + let innerCtx = { ctx with ExecutionPlan = innerPlan } match value with | :? string as s -> - let! inner = innerfn ctx (s) + let! inner = innerfn innerCtx (s) return [| inner |] :> obj | :? System.Collections.IEnumerable as enumerable -> let! completed = enumerable |> Seq.cast - |> Seq.map (fun x -> innerfn ctx x) + |> Seq.map (fun x -> innerfn innerCtx x) |> Job.conCollect return completed.ToArray() :> obj | _ -> return raise ( @@ -256,20 +234,26 @@ let rec createCompletion (possibleTypesFn: TypeDef -> ObjectDef []) (returnDef: let resolver = resolveInterfaceType possibleTypesFn idef fun ctx value -> job { let resolvedDef = resolver value - return! executePlanInfo resolvedDef ctx value + let (ResolveAbstraction(_, typeMap)) = ctx.ExecutionPlan + match Map.tryFind resolvedDef.Name typeMap with + | Some fields -> return! executeFields resolvedDef ctx value fields + | None -> return raise(GraphQLException (sprintf "GraphQL interface '%s' is not implemented by the type '%s'" idef.Name resolvedDef.Name)) } | Union udef -> let resolver = resolveUnionType possibleTypesFn udef fun ctx value -> job { let resolvedDef = resolver value - return! executePlanInfo resolvedDef ctx (udef.ResolveValue value) + let (ResolveAbstraction(_, typeMap)) = ctx.ExecutionPlan + match Map.tryFind resolvedDef.Name typeMap with + | Some fields -> return! executeFields resolvedDef ctx (udef.ResolveValue value) fields + | None -> return raise(GraphQLException (sprintf "GraphQL union '%s' doesn't have a case of type '%s'" udef.Name resolvedDef.Name)) } | Enum _ -> fun _ value -> let result = coerceStringValue value Job.result (result |> Option.map box |> Option.toObj) -and private compileField possibleTypesFn (fieldDef: FieldDef) : ExecuteField = +and internal compileField possibleTypesFn (fieldDef: FieldDef) : ExecuteField = let completed = createCompletion possibleTypesFn (fieldDef.Type) let resolve = fieldDef.Resolve fun resolveFieldCtx value -> job { @@ -302,27 +286,9 @@ and private createFieldContext objdef ctx (info: ExecutionPlanInfo) = ParentType = objdef Schema = ctx.Schema Args = args - Variables = ctx.Variables } - -and executePlanInfo (objdef: ObjectDef) ctx value : Job = - match ctx.ExecutionPlan with - | ResolveValue data -> data.Definition.Execute ctx value - | SelectFields(data, fieldInfos) -> - let nestedValue = data.Definition.Execute ctx value - executeFields objdef ctx nestedValue fieldInfos - | ResolveCollection(data, info) -> - let innerCtx = createFieldContext objdef ctx info - data.Definition.Execute innerCtx value - | ResolveAbstraction(data, typeFields) -> - match Map.tryFind objdef.Name typeFields with - | Some fieldInfos -> - let nestedValue = data.Definition.Execute ctx value - executeFields objdef ctx nestedValue fieldInfos - | None -> - let (Named named) = data.ParentDef - Job.raises (GraphQLException (sprintf "Type '%s' cannot abstract over type '%s'" named.Name objdef.Name)) + Variables = ctx.Variables } -and executeFields (objdef: ObjectDef) (ctx: ResolveFieldContext) value fieldInfos = job { +and private executeFields (objdef: ObjectDef) (ctx: ResolveFieldContext) (value: obj) fieldInfos : Job = job { let resultSet = fieldInfos |> List.filter (fun info -> info.Data.Include ctx.Variables) @@ -335,12 +301,12 @@ and executeFields (objdef: ObjectDef) (ctx: ResolveFieldContext) value fieldInfo do! resultSet |> Array.map (fun (name, info) -> job { let innerCtx = createFieldContext objdef ctx info - let! res = executePlanInfo objdef innerCtx value + let! res = info.Data.Definition.Execute innerCtx value do result.Update name res }) |> Job.conIgnore return box result } -let executePlan (ctx: ExecutionContext) (plan: ExecutionPlan) (objdef: ObjectDef) value = job { +let internal executePlan (ctx: ExecutionContext) (plan: ExecutionPlan) (objdef: ObjectDef) value = job { let resultSet = plan.Fields |> List.filter (fun info -> info.Data.Include ctx.Variables) @@ -363,7 +329,7 @@ let executePlan (ctx: ExecutionContext) (plan: ExecutionPlan) (objdef: ObjectDef Schema = ctx.Schema Args = args Variables = ctx.Variables } - let! res = executePlanInfo objdef fieldCtx value + let! res = info.Data.Definition.Execute fieldCtx value do result.Update name res }) |> match plan.Strategy with | Parallel -> Job.conIgnore @@ -405,8 +371,3 @@ let internal evaluate (schema: #ISchema) (executionPlan: ExecutionPlan) (variabl Errors = errors } return! executePlan ctx executionPlan schema.Query root } |> Async.Global.ofJob - -// we don't need to know possible types at this point -SchemaMetaFieldDef.Execute <- compileField Unchecked.defaultof ObjectDef[]> SchemaMetaFieldDef -TypeMetaFieldDef.Execute <- compileField Unchecked.defaultof ObjectDef[]> TypeMetaFieldDef -TypeNameMetaFieldDef.Execute <- compileField Unchecked.defaultof ObjectDef[]> TypeNameMetaFieldDef \ No newline at end of file diff --git a/src/FSharp.Data.GraphQL/Planning.fs b/src/FSharp.Data.GraphQL/Planning.fs index ebdc6b889..994bfe0b8 100644 --- a/src/FSharp.Data.GraphQL/Planning.fs +++ b/src/FSharp.Data.GraphQL/Planning.fs @@ -156,6 +156,7 @@ and private planSelection (ctx: PlanningContext) (data: PlanningData) (selection let plannedFields = selectionSet |> List.fold(fun (fields: ExecutionPlanInfo list) selection -> + //FIXME: includer is not passed along from top level fragments (both inline and spreads) let includer = getIncluder selection.Directives match selection with | Field field -> diff --git a/src/FSharp.Data.GraphQL/Schema.fs b/src/FSharp.Data.GraphQL/Schema.fs index 463d67e02..034e746a8 100644 --- a/src/FSharp.Data.GraphQL/Schema.fs +++ b/src/FSharp.Data.GraphQL/Schema.fs @@ -21,6 +21,14 @@ type SchemaConfig = Directives = [IncludeDirective; SkipDirective] } type Schema<'Root> (query: ObjectDef<'Root>, ?mutation: ObjectDef<'Root>, ?config: SchemaConfig) as this = + //FIXME: for some reason static do or do invocation in module doesn't work + // for this reason we're compiling executors as part of identifier evaluation + let __done = + // we don't need to know possible types at this point + SchemaMetaFieldDef.Execute <- compileField Unchecked.defaultof ObjectDef[]> SchemaMetaFieldDef + TypeMetaFieldDef.Execute <- compileField Unchecked.defaultof ObjectDef[]> TypeMetaFieldDef + TypeNameMetaFieldDef.Execute <- compileField Unchecked.defaultof ObjectDef[]> TypeNameMetaFieldDef + let rec insert ns typedef = let inline addOrReturn tname (tdef: NamedDef) acc = if Map.containsKey tname acc @@ -286,3 +294,4 @@ type Schema<'Root> (query: ObjectDef<'Root>, ?mutation: ObjectDef<'Root>, ?confi interface System.Collections.IEnumerable with member x.GetEnumerator() = (typeMap |> Map.toSeq |> Seq.map snd :> System.Collections.IEnumerable).GetEnumerator() + \ No newline at end of file diff --git a/tests/FSharp.Data.GraphQL.Benchmarks/ExecutionBenchmark.fs b/tests/FSharp.Data.GraphQL.Benchmarks/ExecutionBenchmark.fs index a28b230fc..2734b5138 100644 --- a/tests/FSharp.Data.GraphQL.Benchmarks/ExecutionBenchmark.fs +++ b/tests/FSharp.Data.GraphQL.Benchmarks/ExecutionBenchmark.fs @@ -1,6 +1,5 @@ /// The MIT License (MIT) /// Copyright (c) 2016 Bazinga Technologies Inc - module FSharp.Data.GraphQL.ExecutionBenchmark open System @@ -18,7 +17,7 @@ type Person = let humans = [ { Id = "1000" Name = Some "Luke Skywalker" - Friends = [ "1002"; "1003"; ] + Friends = [ "1002"; "1003" ] HomePlanet = Some "Tatooine" } { Id = "1001" Name = Some "Darth Vader" @@ -26,11 +25,11 @@ let humans = HomePlanet = Some "Tatooine" } { Id = "1002" Name = Some "Han Solo" - Friends = [ "1000"; "1003"; ] + Friends = [ "1000"; "1003" ] HomePlanet = None } { Id = "1003" Name = Some "Leia Organa" - Friends = [ "1000"; "1002"; ] + Friends = [ "1000"; "1002" ] HomePlanet = Some "Alderaan" } { Id = "1004" Name = Some "Wilhuff Tarkin" @@ -39,30 +38,32 @@ let humans = let getPerson id = humans |> List.tryFind (fun h -> h.Id = id) -let rec Person = Define.Object( - name = "Person", - isTypeOf = (fun o -> o :? Person), - fieldsFn = fun() -> [ - Define.Field("id", String, resolve = fun _ person -> person.Id) - Define.Field("name", Nullable String, resolve = fun _ person -> person.Name) - Define.Field("friends", Nullable (ListOf (Nullable Person)), resolve = fun _ person -> person.Friends |> List.map getPerson |> List.toSeq |> Some) - Define.Field("homePlanet", String) ]) - -let Query = Define.Object( - name = "Query", - fields = [ - Define.Field("hero", Nullable Person, "Retrieves a person by provided id", [ Define.Input("id", String) ], fun ctx () -> getPerson (ctx.Arg("id"))) - ]) +let rec Person = + Define.Object(name = "Person", isTypeOf = (fun o -> o :? Person), + fieldsFn = fun () -> + [ Define.Field("id", String, resolve = fun _ person -> person.Id) + Define.Field("name", Nullable String, resolve = fun _ person -> person.Name) + Define.Field("friends", Nullable(ListOf(Nullable Person)), + resolve = fun _ person -> + person.Friends + |> List.map getPerson + |> List.toSeq + |> Some) + Define.Field("homePlanet", String) ]) +let Query = + Define.Object + (name = "Query", + fields = [ Define.Field + ("hero", Nullable Person, "Retrieves a person by provided id", [ Define.Input("id", String) ], + fun ctx () -> getPerson (ctx.Arg("id"))) ]) let schema = Schema(Query) - let simpleQueryString = """{ hero(id: "1000") { id } }""" let simpleAst = parse simpleQueryString - let flatQueryString = """{ hero(id: "1000") { id, @@ -71,7 +72,6 @@ let flatQueryString = """{ } }""" let flatAst = parse flatQueryString - let nestedQueryString = """{ hero(id: "1000") { id, @@ -96,25 +96,57 @@ open BenchmarkDotNet.Attributes [)>] type SimpleExecutionBenchmark() = - [] member x.Setup () = () - [] member x.BenchmarkSimpleQueryUnparsed () = schema.AsyncExecute(simpleQueryString) |> Async.RunSynchronously - [] member x.BenchmarkSimpleQueryParsed () = schema.AsyncExecute(simpleAst) |> Async.RunSynchronously - [] member x.BenchmarkFlatQueryUnparsed () = schema.AsyncExecute(flatQueryString) |> Async.RunSynchronously - [] member x.BenchmarkFlatQueryParsed () = schema.AsyncExecute(flatAst) |> Async.RunSynchronously - [] member x.BenchmarkNestedQueryUnparsed () = schema.AsyncExecute(nestedQueryString) |> Async.RunSynchronously - [] member x.BenchmarkNestedQueryParsed () = schema.AsyncExecute(nestedAst) |> Async.RunSynchronously + [] + member x.Setup() = () + + [] + member x.BenchmarkSimpleQueryUnparsed() = schema.AsyncExecute(simpleQueryString) |> Async.RunSynchronously + + [] + member x.BenchmarkSimpleQueryParsed() = schema.AsyncExecute(simpleAst) |> Async.RunSynchronously + + [] + member x.BenchmarkFlatQueryUnparsed() = schema.AsyncExecute(flatQueryString) |> Async.RunSynchronously + + [] + member x.BenchmarkFlatQueryParsed() = schema.AsyncExecute(flatAst) |> Async.RunSynchronously + + [] + member x.BenchmarkNestedQueryUnparsed() = schema.AsyncExecute(nestedQueryString) |> Async.RunSynchronously + + [] + member x.BenchmarkNestedQueryParsed() = schema.AsyncExecute(nestedAst) |> Async.RunSynchronously + [)>] type RepeatableExecutionBenchmark() = - let repeat times action = + + let repeat times action = for i in 0..times do - action() |> Async.RunSynchronously |> ignore + action() + |> Async.RunSynchronously + |> ignore + let N = 1000 let repeatN = repeat N - [] member x.Setup () = () - [] member x.BenchmarkSimpleQueryUnparsed () = repeatN <| fun () -> schema.AsyncExecute(simpleQueryString) - [] member x.BenchmarkSimpleQueryParsed () = repeatN <| fun () -> schema.AsyncExecute(simpleAst) - [] member x.BenchmarkFlatQueryUnparsed () = repeatN <| fun () -> schema.AsyncExecute(flatQueryString) - [] member x.BenchmarkFlatQueryParsed () = repeatN <| fun () -> schema.AsyncExecute(flatAst) - [] member x.BenchmarkNestedQueryUnparsed () = repeatN <| fun () -> schema.AsyncExecute(nestedQueryString) - [] member x.BenchmarkNestedQueryParsed () = repeatN <| fun () -> schema.AsyncExecute(nestedAst) \ No newline at end of file + + [] + member x.Setup() = () + + [] + member x.BenchmarkSimpleQueryUnparsed() = repeatN <| fun () -> schema.AsyncExecute(simpleQueryString) + + [] + member x.BenchmarkSimpleQueryParsed() = repeatN <| fun () -> schema.AsyncExecute(simpleAst) + + [] + member x.BenchmarkFlatQueryUnparsed() = repeatN <| fun () -> schema.AsyncExecute(flatQueryString) + + [] + member x.BenchmarkFlatQueryParsed() = repeatN <| fun () -> schema.AsyncExecute(flatAst) + + [] + member x.BenchmarkNestedQueryUnparsed() = repeatN <| fun () -> schema.AsyncExecute(nestedQueryString) + + [] + member x.BenchmarkNestedQueryParsed() = repeatN <| fun () -> schema.AsyncExecute(nestedAst) diff --git a/tests/FSharp.Data.GraphQL.Tests/ExecutionTests.fs b/tests/FSharp.Data.GraphQL.Tests/ExecutionTests.fs index bf9fefc3a..783dd202f 100644 --- a/tests/FSharp.Data.GraphQL.Tests/ExecutionTests.fs +++ b/tests/FSharp.Data.GraphQL.Tests/ExecutionTests.fs @@ -82,7 +82,7 @@ let ``Execution handles basic tasks: executes arbitrary code`` () = "e", upcast "Egg" "f", upcast "Fish" "pic", upcast "Pic of size: 100" - "promise", null + "promise", upcast NameValueLookup.ofList [ "a", upcast "Apple" ] "deep", upcast NameValueLookup.ofList [ "a", "Already Been Done" :> obj "b", upcast "Boring" @@ -95,7 +95,7 @@ let ``Execution handles basic tasks: executes arbitrary code`` () = Define.Field("b", String, (fun _ dt -> dt.b)) Define.Field("c", (ListOf String), (fun _ dt -> upcast dt.c)) ]) - let DataType = Define.Object("DataType", fields = [ + let rec DataType = Define.Object("DataType", fieldsFn = fun () -> [ Define.Field("a", String, fun _ dt -> dt.a) Define.Field("b", String, fun _ dt -> dt.b) Define.Field("c", String, fun _ dt -> dt.c) @@ -103,6 +103,7 @@ let ``Execution handles basic tasks: executes arbitrary code`` () = Define.Field("e", String, fun _ dt -> dt.e) Define.Field("f", String, fun _ dt -> dt.f) Define.Field("pic", String, "Picture resizer", [ Define.Input("size", Nullable Int) ], fun ctx dt -> dt.pic(ctx.Arg("size"))) + Define.AsyncField("promise", DataType, fun _ dt -> dt.promise) Define.Field("deep", DeepDataType, fun _ dt -> dt.deep) ]) From 438ad28bcc1ea51bfd887d067adfd94ab720ace9 Mon Sep 17 00:00:00 2001 From: Bartosz Sypytkowski Date: Tue, 19 Jul 2016 11:00:36 +0200 Subject: [PATCH 7/7] planning phase finished --- src/FSharp.Data.GraphQL/Execution.fs | 4 +- src/FSharp.Data.GraphQL/Planning.fs | 38 ++++++++++--------- .../FSharp.Data.GraphQL.Tests/SchemaTests.fs | 7 +++- .../UnionInterfaceTests.fs | 14 ++----- 4 files changed, 33 insertions(+), 30 deletions(-) diff --git a/src/FSharp.Data.GraphQL/Execution.fs b/src/FSharp.Data.GraphQL/Execution.fs index 1119b7134..e9bcb6689 100644 --- a/src/FSharp.Data.GraphQL/Execution.fs +++ b/src/FSharp.Data.GraphQL/Execution.fs @@ -187,7 +187,7 @@ let resolveUnionType possibleTypesFn (uniondef: UnionDef) = match uniondef.ResolveType with | Some resolveType -> resolveType | None -> defaultResolveType possibleTypesFn uniondef - + let rec createCompletion (possibleTypesFn: TypeDef -> ObjectDef []) (returnDef: OutputDef): ResolveFieldContext -> obj -> Job = match returnDef with | Object objdef -> @@ -215,7 +215,7 @@ let rec createCompletion (possibleTypesFn: TypeDef -> ObjectDef []) (returnDef: |> Seq.cast |> Seq.map (fun x -> innerfn innerCtx x) |> Job.conCollect - return completed.ToArray() :> obj + return box (completed.ToArray()) | _ -> return raise ( GraphQLException (sprintf "Expected to have enumerable value in field '%s' but got '%O'" ctx.ExecutionPlan.Data.Identifier (value.GetType()))) } diff --git a/src/FSharp.Data.GraphQL/Planning.fs b/src/FSharp.Data.GraphQL/Planning.fs index 994bfe0b8..7cbb4e611 100644 --- a/src/FSharp.Data.GraphQL/Planning.fs +++ b/src/FSharp.Data.GraphQL/Planning.fs @@ -73,7 +73,7 @@ let objectData(ctx: PlanningContext, parentDef: ObjectDef, field: Field, include | None -> raise (GraphQLException (sprintf "No field '%s' was defined in object definition '%s'" field.Name parentDef.Name)) -let abstractionData(ctx: PlanningContext, parentDef: AbstractDef, field: Field, typeCondition: string option, includer: Includer) : Map = +let rec abstractionData (ctx:PlanningContext) (parentDef: AbstractDef) (field: Field) typeCondition includer : Map = let objDefs = ctx.Schema.GetPossibleTypes parentDef match typeCondition with | None -> @@ -106,8 +106,12 @@ let abstractionData(ctx: PlanningContext, parentDef: AbstractDef, field: Field, Map.ofList [ objDef.Name, data ] | None -> Map.empty | None -> - let pname = parentDef :?> NamedDef - raise (GraphQLException (sprintf "An abstract type '%s' has no relation with a type named '%s'" pname.Name typeName)) + match ctx.Schema.TryFindType typeName with + | Some (Abstract abstractDef) -> + abstractionData ctx abstractDef field None includer + | _ -> + let pname = parentDef :?> NamedDef + raise (GraphQLException (sprintf "There is no object type named '%s' that is a possible type of '%s'" typeName pname.Name)) let private directiveIncluder (directive: Directive) : Includer = fun variables -> @@ -121,17 +125,15 @@ let private directiveIncluder (directive: Directive) : Includer = let incl: Includer = fun _ -> true let excl: Includer = fun _ -> false -let private getIncluder (directives: Directive list) : Includer = +let private getIncluder (directives: Directive list) topIncluder : Includer = directives |> List.fold (fun acc directive -> match directive.Name with | "skip" -> - let excluder = directiveIncluder directive >> not - fun vars -> acc vars && excluder vars + fun vars -> acc vars && not(directiveIncluder directive vars) | "include" -> - let includer = directiveIncluder directive - fun vars -> acc vars && includer vars - | _ -> acc) incl + fun vars -> acc vars && (directiveIncluder directive vars) + | _ -> acc) topIncluder let private doesFragmentTypeApply (schema: ISchema) fragment (objectType: ObjectDef) = match fragment.TypeCondition with @@ -142,7 +144,7 @@ let private doesFragmentTypeApply (schema: ISchema) fragment (objectType: Object | Some conditionalType when conditionalType.Name = objectType.Name -> true | Some (Abstract conditionalType) -> schema.IsPossibleType conditionalType objectType | _ -> false - + let rec private plan (ctx: PlanningContext) (data: PlanningData) (typedef: TypeDef) : ExecutionPlanInfo = match typedef with | Leaf leafDef -> planLeaf ctx data leafDef @@ -157,7 +159,8 @@ and private planSelection (ctx: PlanningContext) (data: PlanningData) (selection selectionSet |> List.fold(fun (fields: ExecutionPlanInfo list) selection -> //FIXME: includer is not passed along from top level fragments (both inline and spreads) - let includer = getIncluder selection.Directives + let includer = getIncluder selection.Directives data.Include + let innerData = { data with Include = includer } match selection with | Field field -> let identifier = field.AliasOrName @@ -176,13 +179,13 @@ and private planSelection (ctx: PlanningContext) (data: PlanningData) (selection match ctx.Document.Definitions |> List.tryFind (function FragmentDefinition f -> f.Name.Value = spreadName | _ -> false) with | Some (FragmentDefinition fragment) when doesFragmentTypeApply ctx.Schema fragment parentDef -> // retrieve fragment data just as it was normal selection set - let (SelectFields(_, fragmentFields)) = planSelection ctx data fragment.SelectionSet visitedFragments + let (SelectFields(_, fragmentFields)) = planSelection ctx innerData fragment.SelectionSet visitedFragments // filter out already existing fields List.mergeBy (fun field -> field.Data.Identifier) fields fragmentFields | _ -> fields | InlineFragment fragment when doesFragmentTypeApply ctx.Schema fragment parentDef -> // retrieve fragment data just as it was normal selection set - let (SelectFields(_, fragmentFields)) = planSelection ctx data fragment.SelectionSet visitedFragments + let (SelectFields(_, fragmentFields)) = planSelection ctx innerData fragment.SelectionSet visitedFragments // filter out already existing fields List.mergeBy (fun field -> field.Data.Identifier) fields fragmentFields | _ -> fields @@ -200,10 +203,11 @@ and private planAbstraction (ctx:PlanningContext) (data: PlanningData) (selectio let plannedTypeFields = selectionSet |> List.fold(fun (fields: Map) selection -> - let includer = getIncluder selection.Directives + let includer = getIncluder selection.Directives data.Include + let innerData = { data with Include = includer } match selection with | Field field -> - abstractionData(ctx, parentDef, field, typeCondition, includer) + abstractionData ctx parentDef field typeCondition includer |> Map.map (fun typeName data -> [ plan ctx data data.Definition.Type ]) |> Map.merge (fun typeName oldVal newVal -> oldVal @ newVal) fields | FragmentSpread spread -> @@ -215,13 +219,13 @@ and private planAbstraction (ctx:PlanningContext) (data: PlanningData) (selectio match ctx.Document.Definitions |> List.tryFind (function FragmentDefinition f -> f.Name.Value = spreadName | _ -> false) with | Some (FragmentDefinition fragment) -> // retrieve fragment data just as it was normal selection set - let (ResolveAbstraction(_, fragmentFields)) = planAbstraction ctx data fragment.SelectionSet visitedFragments fragment.TypeCondition + let (ResolveAbstraction(_, fragmentFields)) = planAbstraction ctx innerData fragment.SelectionSet visitedFragments fragment.TypeCondition // filter out already existing fields Map.merge (fun typeName oldVal newVal -> oldVal @ newVal) fields fragmentFields | _ -> fields | InlineFragment fragment -> // retrieve fragment data just as it was normal selection set - let (ResolveAbstraction(_, fragmentFields)) = planAbstraction ctx data fragment.SelectionSet visitedFragments fragment.TypeCondition + let (ResolveAbstraction(_, fragmentFields)) = planAbstraction ctx innerData fragment.SelectionSet visitedFragments fragment.TypeCondition // filter out already existing fields Map.merge (fun typeName oldVal newVal -> oldVal @ newVal) fields fragmentFields | _ -> fields diff --git a/tests/FSharp.Data.GraphQL.Tests/SchemaTests.fs b/tests/FSharp.Data.GraphQL.Tests/SchemaTests.fs index b81a22f3a..74ab460c3 100644 --- a/tests/FSharp.Data.GraphQL.Tests/SchemaTests.fs +++ b/tests/FSharp.Data.GraphQL.Tests/SchemaTests.fs @@ -26,4 +26,9 @@ let ``Object type should be able to merge fields with matching signatures from d Define.Field("speed", Int) Define.Field("acceleration", Int) ]) equals [ MovableType :> InterfaceDef; upcast Movable2Type ] (PersonType.Implements |> Array.toList ) - equals [ Define.Field("name", String) :> FieldDef; upcast Define.Field("speed", Int); upcast Define.Field("acceleration", Int) ] (( PersonType :> ObjectDef).Fields |> Map.toList |> List.map snd) \ No newline at end of file + let expected = + //NOTE: under normal conditions field order shouldn't matter in object definitions + [ Define.Field("acceleration", Int) :> FieldDef + upcast Define.Field("name", String) + upcast Define.Field("speed", Int) ] + equals expected (( PersonType :> ObjectDef).Fields |> Map.toList |> List.map snd) \ No newline at end of file diff --git a/tests/FSharp.Data.GraphQL.Tests/UnionInterfaceTests.fs b/tests/FSharp.Data.GraphQL.Tests/UnionInterfaceTests.fs index 1f815fe82..4aed82841 100644 --- a/tests/FSharp.Data.GraphQL.Tests/UnionInterfaceTests.fs +++ b/tests/FSharp.Data.GraphQL.Tests/UnionInterfaceTests.fs @@ -35,8 +35,7 @@ type Person = { Name: string; Pets: Pet list; Friends: INamed list } interface INamed with member x.Name = x.Name - - + let NamedType = Define.Interface( name = "Named", fields = [ Define.Field("name", String) ]) @@ -158,13 +157,11 @@ let ``Executes union types`` () = box <| NameValueLookup.ofList [ "__typename", box "Cat" "name", upcast "Garfield" - "barks", null "meows", upcast false] upcast NameValueLookup.ofList [ "__typename", box "Dog" "name", upcast "Odie" - "barks", upcast true - "meows", null]]] + "barks", upcast true]]] noErrors actual actual.["data"] |> equals (upcast expected) @@ -222,14 +219,11 @@ let ``Executes interface types`` () = "friends", upcast [ box <| NameValueLookup.ofList [ "__typename", box "Person" - "name", upcast "Liz" - "barks", null - "meows", null] + "name", upcast "Liz" ] upcast NameValueLookup.ofList [ "__typename", box "Dog" "name", upcast "Odie" - "barks", upcast true - "meows", null]]] + "barks", upcast true ]]] noErrors actual actual.["data"] |> equals (upcast expected)