File Coverage

blib/lib/JSON/Schema/Modern/Document.pm

Criterion	Covered	Total	%
statement	186	189	98.4
branch	40	48	83.3
condition	20	28	71.4
subroutine	43	45	95.5
pod	5	14	35.7
total	294	324	90.7

use strict;
use warnings;
package JSON::Schema::Modern::Document;
# vim: set ts=8 sts=2 sw=2 tw=100 et :
# ABSTRACT: One JSON Schema document

our $VERSION = '0.634';

use 5.020;
use Moo;
use strictures 2;
use stable 0.031 'postderef';
use experimental 'signatures';
no autovivification warn => qw(fetch store exists delete);
use if "$]" >= 5.022, experimental => 're_strict';
no if "$]" >= 5.031009, feature => 'indirect';
no if "$]" >= 5.033001, feature => 'multidimensional';
no if "$]" >= 5.033006, feature => 'bareword_filehandles';
no if "$]" >= 5.041009, feature => 'smartmatch';
no feature 'switch';
use Mojo::URL;
use Carp 'croak';
use List::Util 1.29 'pairs';
use builtin::compat qw(refaddr blessed);
use Safe::Isa 1.000008;
use MooX::TypeTiny;
use Types::Standard 1.016003 qw(InstanceOf HashRef Str Map Dict ArrayRef Enum ClassName Undef Slurpy Optional Bool);
use Types::Common::Numeric 'PositiveOrZeroInt';
use JSON::Schema::Modern::Utilities qw(json_pointer_type canonical_uri_type E);
use namespace::clean;

extends 'Mojo::JSON::Pointer';

has schema => (
  is => 'ro',
  required => 1,
);

has canonical_uri => (
  is => 'rwp',
  isa => (InstanceOf['Mojo::URL'])->where(q{not defined $_->fragment}),
  lazy => 1,
  default => sub { Mojo::URL->new },
  coerce => sub { $_[0]->$_isa('Mojo::URL') ? $_[0] : Mojo::URL->new($_[0]) },
);

# this is also known as the retrieval uri in the OpenAPI specification
has original_uri => (
  is => 'rwp',
  isa => (InstanceOf['Mojo::URL'])->where(q{not defined $_->fragment}),
  init_arg => undef,
);
*retrieval_uri = \&original_uri;

has metaschema_uri => (
  is => 'rwp',
  isa => InstanceOf['Mojo::URL'],
  coerce => sub { $_[0]->$_isa('Mojo::URL') ? $_[0] : Mojo::URL->new($_[0]) },
  predicate => '_has_metaschema_uri',
  # default not defined here, but might be defined in a subclass
);

# "A JSON Schema resource is a schema which is canonically identified by an absolute URI."
# https://json-schema.org/draft/2020-12/json-schema-core.html#rfc.section.4.3.5
has resource_index => (
  is => 'bare',
  isa => Map[my $resource_key_type = Str->where('!/#/'), my $resource_type = Dict[
      canonical_uri => (InstanceOf['Mojo::URL'])->where(q{not defined $_->fragment}),
      path => json_pointer_type,  # JSON pointer relative to the document root
      specification_version => Enum[qw(draft4 draft6 draft7 draft2019-09 draft2020-12)],
      # the vocabularies used when evaluating instance data against schema
      vocabularies => ArrayRef[ClassName->where(q{$_->DOES('JSON::Schema::Modern::Vocabulary')})],
      anchors => Optional[HashRef[Dict[
        canonical_uri => canonical_uri_type,  # equivalent uri with json pointer fragment
        path => json_pointer_type,  # JSON pointer relative to the document root
        dynamic => Optional[Bool],
      ]]],
      Slurpy[HashRef[Undef]],  # no other fields allowed
    ]],
  init_arg => undef,
  default => sub { {} },
);

sub resource_index { $_[0]->{resource_index}->%* }
sub resource_pairs { pairs $_[0]->{resource_index}->%* }
sub _get_resource { $_[0]->{resource_index}{$_[1]} }
sub _canonical_resources { values $_[0]->{resource_index}->%* }
sub _add_resource {
  croak 'uri "'.$_[1].'" conflicts with an existing schema resource' if $_[0]->{resource_index}{$_[1]};
  $_[0]->{resource_index}{$resource_key_type->($_[1])} = $resource_type->($_[2]);
}

# for internal use only
has _checksum => (
  is => 'rw',
  isa => Str,
  init_arg => undef,
);

has errors => (
  is => 'bare',
  writer => '_set_errors',
  isa => ArrayRef[InstanceOf['JSON::Schema::Modern::Error']],
  lazy => 1,
  default => sub { [] },
);

sub errors { ($_[0]->{errors}//[])->@* }
sub has_errors { scalar(($_[0]->{errors}//[])->@*) }

# json pointer => entity name (indexed by integer)
has _entities => (
  is => 'ro',
  isa => Map[json_pointer_type, PositiveOrZeroInt],
  lazy => 1,
  default => sub { {} },
);

# in this class, the only entity type is 'schema', but subclasses add more
sub __entities ($) { qw(schema) }
sub __entity_type { Enum[$_[0]->__entities] }
sub __entity_index ($self, $entity) {
  my @e = $self->__entities;
  foreach my $i (0..$#e) { return $i if $e[$i] eq $entity; }
  return undef;
}

sub _add_entity_location ($self, $location, $entity) {
  $self->__entity_type->($entity); # verify string
  $self->_entities->{$location} = $self->__entity_index($entity); # store integer-mapped value
}

sub get_entity_at_location ($self, $location) {
  return '' if not exists $self->_entities->{$location};
  ($self->__entities)[ $self->_entities->{$location} ] // croak "missing mapping for ", $self->_entities->{$location};
}

# note: not sorted
sub get_entity_locations ($self, $entity) {
  $self->__entity_type->($entity); # verify string
  my $index = $self->__entity_index($entity);
  grep $self->{_entities}{$_} == $index, keys $self->{_entities}->%*;
}

# shims for Mojo::JSON::Pointer
sub data { shift->schema(@_) }
sub FOREIGNBUILDARGS { () }

# for JSON serializers
sub TO_JSON { shift->schema }

# note that this is always called, even in subclasses
sub BUILD ($self, $args) {
  # note! not a clone! Please don't change canonical_uri in-place.
  $self->_set_original_uri($self->canonical_uri);

  # this should extract all identifiers, references, and entities, and set canonical_uri,
  # metaschema_uri
  my $state = $self->traverse(
    $args->{evaluator} // JSON::Schema::Modern->new,
    {
      $args->{specification_version} ? $args->%{specification_version} : (),
      $args->{skip_ref_checks} ? $args->%{skip_ref_checks} : (),
    },
  );

  if ($state->{errors}->@*) {
    $self->_set_errors($state->{errors});
    return;
  }

  my $seen_root;
  foreach my $key (keys $state->{identifiers}->%*) {
    my $value = $state->{identifiers}{$key};
    $self->_add_resource($key => $value);

    # we're adding a non-anchor entry for the document root
    ++$seen_root if $value->{path} eq '';
  }

  # we only index the original uri if nothing in the schema itself identified a root resource:
  # otherwise the top of the document would be unreferenceable.
  $self->_add_resource($self->original_uri.'' => {
      path => '',
      canonical_uri => $self->canonical_uri,
      $state->%{qw(specification_version vocabularies)},
    })
  if not $seen_root;

  foreach my $ref (($state->{references}//[])->@*) {
    my ($keyword, $path_location, $abs_target, $expected_entity) = @$ref;

    # look for resource locally; fall back to the evaluator's index
    my $resource = $self->_get_resource(my $uri = $abs_target->clone->fragment(undef));
    my $document = $self;

    if (not $resource) {
      $resource = $args->{evaluator}->_get_resource($uri) if $args->{evaluator};
      next if not $resource;
      $document = $resource->{document};
    }

    my $fragment = $abs_target->fragment;
    my $target_path;
    if (not length $fragment or $fragment =~ m{^/}) {
      ()= E({ %$state, keyword_path => $path_location, keyword => $keyword },
          '%s target "%s" is a non-existent location', $keyword, $abs_target), next
        if not $document->contains($target_path = $resource->{path}.($fragment//''));
    }
    elsif (my $subresource = ($resource->{anchors}//{})->{$fragment}) {
      $target_path = $subresource->{path};
    }
    else {
      ()= E({ %$state, keyword_path => $path_location, keyword => $keyword },
        '%s target "%s" is a non-existent location', $keyword, $abs_target);
      next;
    }

    my $entity = $document->get_entity_at_location($target_path);
    ()= E({ %$state, keyword_path => $path_location, keyword => $keyword },
        '%s target "%s" is not a referenceable location', $keyword, $abs_target), next
      if not $entity;

    ()= E({ %$state, keyword_path => $path_location, keyword => $keyword },
        '%s target "%s" is the wrong object type (%s, expecting %s)',
        $keyword, $abs_target, $entity, $expected_entity), next
      if $entity ne $expected_entity;
  }

  $self->_set_errors($state->{errors}) if $state->{errors}->@*;
}

# a subclass's method will override this one
sub traverse ($self, $evaluator, $config_override = {}) {
  die 'wrong class - use JSON::Schema::Modern::Document::OpenAPI instead'
    if ref $self->schema eq 'HASH' and exists $self->schema->{openapi};

  my $original_uri = $self->original_uri;

  my $state = $evaluator->traverse($self->schema,
    {
      initial_schema_uri => $original_uri,
      $self->_has_metaschema_uri ? (metaschema_uri => $self->metaschema_uri) : (),
      %$config_override,
    }
  );

  die 'original_uri has changed' if $self->original_uri ne $original_uri
    or refaddr($self->original_uri) != refaddr($original_uri);

  # if the document identified a canonical uri for itself via '$id', or metaschema uri via '$schema',
  # they overrides the initial values
  # Note that subclasses of this class may choose to identify these values in a different way
  # (e.g. "$self" in OpenAPI)
  $self->_set_canonical_uri($state->{initial_schema_uri});
  $self->_set_metaschema_uri($state->{metaschema_uri});

  $self->_add_entity_location($_, 'schema') foreach $state->{subschemas}->@*;

  return $state;
}

sub validate ($class, @args) {
  croak 'bad argument list' if blessed($args[0]);

  my $args = $class->Moo::Object::BUILDARGS(@args);
  my $document = blessed($class) ? $class : $class->new($args);

  my $doc_result = JSON::Schema::Modern::Result->new(errors => [ $document->errors ]);

  # ideally, the traverse phase run during document construction should have found all errors that a
  # simple metaschema evaluation would reveal, but we'll do both just to make sure.
  my $evaluator = $args->{evaluator} // JSON::Schema::Modern->new(validate_formats => 1);
  my $eval_result = $evaluator->evaluate($document->schema, $document->metaschema_uri);

  if (my ($missing_resource) = grep $_->error =~ /EXCEPTION: unable to find resource/, $eval_result->errors) {
    $missing_resource->{error} .= ' (did you forget to provide "evaluator" to ->validate?)';
  }

  return $doc_result & $eval_result;
}

# callback hook for Sereal::Encoder
sub FREEZE ($self, $serializer) { +{ %$self } }

# callback hook for Sereal::Decoder
sub THAW ($class, $serializer, $data) {
  delete $data->{evaluator};

  my $self = bless($data, $class);

  foreach my $attr (qw(schema _entities)) {
    croak "serialization missing attribute '$attr' on document for identifier '$self->{canonical_uri}': perhaps your serialized data was produced for an older version of $class?"
      if not exists $self->{$attr};
  }
  return $self;
}

1;

__END__