# DONE
# 5.4.1
# √5.4.1.1 - Fragment Name Uniqueness
# √5.4.1.2 - Fragment Spread Type Existence
# √5.4.1.3 - Fragments On Composite Types
# √5.4.1.4 - Fragments Must Be Used
# 5.4.2
# √5.4.2.1 - Fragment spread target defined
# √5.4.2.2 - Fragment spreads must not form cycles
# √5.4.2.3 - Fragment spread is possible
# √5.4.2.3.1 - Object Spreads In Object Scope - covered in 5.4.2.3
# √5.4.2.3.2 - Abstract Spreads in Object Scope - covered in 5.4.2.3
# √5.4.2.3.3 - Object Spreads In Abstract Scope - covered in 5.4.2.3
# √5.4.2.3.4 - Abstract Spreads in Abstract Scope - covered in 5.4.2.3
upgrade_query_remove_fragments <- function(document_obj, ..., oh) {
fragment_list <- list()
query_mutation_list <- list(
query = list(),
mutation = list()
)
for (operation in document_obj$definitions) {
if (inherits(operation, "OperationDefinition")) {
# is operation
if (operation$operation == "query") {
if (is.null(operation$name)) {
query_mutation_list$query[[""]] <- operation
} else {
query_mutation_list$query[[format(operation$name)]] <- operation
}
} else {
query_mutation_list$mutation[[format(operation$name)]] <- operation
}
} else {
fragment <- operation
fragment_name <- format(fragment$name)
# 5.4.1.1
if (!is.null(fragment_list[[fragment_name]])) {
oh$error_list$add(
"5.4.1.1",
"fragments must have a unique name. Found duplicate fragment: ", fragment_name,
loc = fragment$name$loc
)
next
}
fragment_list[[fragment_name]] <- fragment
}
}
if (oh$error_list$has_any_errors()) {
return(document_obj)
}
fragment_names <- names(fragment_list)
fragment_used_once <- rep(FALSE, length(fragment_names))
names(fragment_used_once) <- fragment_names
# pretend you can see "fragment_used_once" globally
upgrade_fragments_in_field <- function(
field_obj,
matching_obj,
seen_fragments = NULL,
top_level = FALSE
) {
new_selections <- list()
for (field in field_obj$selectionSet$selections) {
if (inherits(field, "Field")) {
# regular field object
if (!is.null(field$selectionSet)) {
# need to recurse in field objects
matching_field <- matching_obj$.get_field(field)
if (top_level && is.null(matching_field)) {
matching_field <-
switch(field$name$value,
"__schema" = Introspection__schema_field,
"__type" = Introspection__type_field,
NULL
)
}
if (is.null(matching_field)) {
# shouldn't be able to be reached?
oh$error_list$add(
"5.2.1",
"Field: ", format(field$name), " can't be found for object of type: ",
format(matching_obj$name),
loc = field$name$loc
)
next
}
matching_field_obj <- get_object_interface_or_union(matching_field$type, oh$schema)
field <- upgrade_fragments_in_field(field, matching_field_obj, seen_fragments)
}
new_selections <- append(new_selections, field)
validate_directives(field$directives, field, oh = oh, skip_variables = TRUE)
} else if (inherits(field, "FragmentSpread") || inherits(field, "InlineFragment")) {
field_seen_fragments <- seen_fragments
# turn all FragmentSpread into InlineFragment; removes lookup at run time
if (inherits(field, "FragmentSpread")) {
# is fragement spread
fragment_spread_name <- format(field$name)
fragment_obj <- fragment_list[[fragment_spread_name]]
validate_directives(field$directives, field, oh = oh)
# 5.4.2.1 - Fragment spread target defined
if (is.null(fragment_obj)) {
oh$error_list$add(
"5.4.2.1",
"fragment must be defined. Can not find fragment named: ", fragment_spread_name,
loc = field$name$loc
)
return(NULL)
}
fragment_used_once[fragment_spread_name] <<- TRUE
# 5.4.2.2 - Fragment spreads must not form cycles
if (fragment_spread_name %in% field_seen_fragments) {
oh$error_list$add(
"5.4.2.2",
"fragments can not be circularly defined. ",
" Start of cycle: ", str_c(field_seen_fragments, collapse = ", "),
loc = field$name$loc
)
return(NULL)
}
field_seen_fragments <- c(field_seen_fragments, fragment_spread_name)
validate_directives(fragment_obj$directives, fragment_obj, oh = oh)
# since the fragment was received, make it "inline fragment"
fragment_obj <- InlineFragment$new(
loc = fragment_obj$loc,
typeCondition = fragment_obj$typeCondition,
directives = fragment_obj$directives,
selectionSet = fragment_obj$selectionSet
)
} else {
# inline_fragment
fragment_obj <- field
validate_directives(fragment_obj$directives, fragment_obj, oh = oh)
}
# at this point the fragment_obj is either a inlinefragment or fragment definition
# it can treated as a fragment spread
if (is.null(fragment_obj$typeCondition)) {
# there is no type condition "on Dog",
# matching_frag_obj is of parent obj
matching_frag_obj <- matching_obj
matching_type_condition <- matching_obj$name
} else {
matching_frag_obj <- get_object_interface_or_union(fragment_obj$typeCondition, oh$schema)
matching_type_condition <- fragment_obj$typeCondition
}
# 5.4.1.2 - Fragment Spread Type Existence - upgrade
# 5.4.1.3 - Fragments On Composite Types
if (is.null(matching_frag_obj)) {
oh$error_list$add(
"5.4.1.3",
"fragment must supply at object, interface, or union.",
" Can not find match for typeCondition: ", format(matching_type_condition),
loc = matching_type_condition$loc
)
return(NULL)
}
get_possible_types <- function(name_obj) {
name_val <- name_value(name_obj)
if (oh$schema$is_object(name_val)) {
return(name_val)
}
if (oh$schema$is_interface(name_val)) {
return(oh$schema$implements_interface(name_val))
}
union_obj <- oh$schema$get_union(name_val)
if (!is.null(union_obj)) {
union_names <- unlist(lapply(union_obj$types, name_value))
return(union_names)
}
stop("type: ", name_val, " is not an object, interface, or union")
}
fragment_possible_types <- get_possible_types(matching_type_condition)
parent_possible_types <- get_possible_types(matching_obj$name)
applicable_types <- intersect(fragment_possible_types, parent_possible_types)
# 5.4.2.3 - Fragment spread is possible
if (length(applicable_types) == 0) {
oh$error_list$add(
"5.4.2.3",
"there must be an intersection of \n",
"\tfragment possible types: ", str_c(fragment_possible_types, collapse = ", "), "\n",
" and \n",
"\tparent possible types: ", str_c(parent_possible_types, collapse = ", "),
loc = matching_type_condition$loc
)
return(NULL)
}
upgraded_fragment <- upgrade_fragments_in_field(
fragment_obj,
matching_frag_obj,
field_seen_fragments
)
# # add all fields to selection set
new_selections <- append(new_selections, upgraded_fragment)
}
}
# upgrade the selectino set
field_obj$selectionSet$selections <- new_selections
field_obj
}
# upgrade all mutation and query objects be full trees, not many fragment objects
# (circular dependencies are not allowed by graphql definition)
upgraded_operations <- list()
if (length(query_mutation_list$mutation) > 0) {
mutation_root <- oh$schema$get_mutation_object()
if (is.null(mutation_root)) {
oh$error_list$add(
"3.3",
"mutation type can not be found in schema definition"
# no loc
)
return(NULL)
}
for (mutation_obj in query_mutation_list$mutation) {
mutation_obj <- upgrade_fragments_in_field(mutation_obj, mutation_root, NULL, top_level = TRUE)
upgraded_operations <- append(upgraded_operations, mutation_obj)
}
}
if (length(query_mutation_list$query) > 0) {
query_root <- oh$schema$get_query_object()
if (is.null(query_root)) {
oh$error_list$add(
"3.3",
"query type can not be found in schema definition"
# no loc
)
return(NULL)
}
for (query_obj in query_mutation_list$query) {
query_obj <- upgrade_fragments_in_field(query_obj, query_root, NULL, top_level = TRUE)
upgraded_operations <- append(upgraded_operations, query_obj)
}
}
# 5.4.1.4 - Fragments Must Be Used
if (!all(fragment_used_once)) {
oh$error_list$add(
"5.4.1.4",
"all fragments must be used.",
" Fragments not used: ", names(fragment_used_once[!fragment_used_once])
# no loc
)
return(document_obj)
}
document_obj$definitions <- upgraded_operations
document_obj
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.