167 lines
3.5 KiB
Perl
167 lines
3.5 KiB
Perl
use 5.32.0;
|
|
|
|
package Dancer2::Plugin::JsonApi::Registry::Schema;
|
|
|
|
use Moo;
|
|
|
|
use experimental qw/ signatures /;
|
|
use List::AllUtils qw/ pairmap pairgrep /;
|
|
|
|
use Set::Object qw/set/;
|
|
|
|
=head1 ATTRIBUTES
|
|
|
|
=head2 type
|
|
|
|
The JSON:API object type. Required.
|
|
|
|
=cut
|
|
|
|
has type => (
|
|
required => 1,
|
|
is => 'ro',
|
|
);
|
|
|
|
=head2 id
|
|
|
|
Key to use as a reference to the object. Defaults to C<id>. Can be a string,
|
|
or a function that will be passed the original data object.
|
|
|
|
=cut
|
|
|
|
has id => (
|
|
is => 'ro',
|
|
default => 'id'
|
|
);
|
|
|
|
has links => (is => 'ro');
|
|
has top_level_links => (is => 'ro');
|
|
has top_level_meta => (is => 'ro');
|
|
has relationships => (is => 'ro', default => sub { +{} });
|
|
|
|
has registry => ( is => 'ro' );
|
|
has allowed_attributes => ( is => 'ro');
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 top_level_serialize($data,$extra_data = {})
|
|
|
|
Serializes C<$data> as a top-level
|
|
JSON:API object.
|
|
|
|
=cut
|
|
|
|
sub serialize ( $self, $data, $extra_data = {} ) {
|
|
|
|
my $serial = {};
|
|
|
|
$serial->{jsonapi} = { version => '1.0' };
|
|
|
|
my @included;
|
|
|
|
$serial->{data} = $self->serialize_data($data,$extra_data,\@included);
|
|
|
|
$serial->{links} = gen_links($self->top_level_links,$data,$extra_data)
|
|
if $self->top_level_links;
|
|
$serial->{meta} = gen_links($self->top_level_meta,$data,$extra_data)
|
|
if $self->top_level_meta;
|
|
|
|
$serial->{included} = [ dedupe_included( @included )] if @included;
|
|
|
|
return $serial;
|
|
}
|
|
|
|
sub dedupe_included {
|
|
my %seen;
|
|
return grep {
|
|
not $seen{$_->{type}}{$_->{id}}++
|
|
} @_;
|
|
}
|
|
|
|
=head2 serialize_data($data,$extra_data)
|
|
|
|
Serializes the inner C<$data>.
|
|
|
|
=cut
|
|
|
|
sub serialize_data ( $self, $data, $extra_data = {}, $included = undef ) {
|
|
|
|
return [ map { $self->serialize_data($_,$extra_data, $included) } @$data ] if ref $data eq 'ARRAY';
|
|
|
|
# it's a scalar? it's the id
|
|
return { id => $data, type => $self->type } unless ref $data;
|
|
|
|
my $s = {
|
|
type => $self->type,
|
|
id => $self->gen_id($data) };
|
|
|
|
if($self->links) {
|
|
$s->{links} = gen_links($self->links,$data,$extra_data);
|
|
}
|
|
|
|
$s->{attributes} = +{ pairgrep { $a ne $self->id } %$data };
|
|
|
|
my %relationships = $self->relationships->%*;
|
|
|
|
for my $key ( keys %relationships ) {
|
|
my $attr = delete $s->{attributes}{$key} or next;
|
|
|
|
my @inc;
|
|
|
|
my $t = $self->registry->serialize(
|
|
$relationships{$key}{type}, $attr, \@inc
|
|
);
|
|
|
|
$s->{relationships}{ $key }{data} = obj_ref($t->{data},\@inc);
|
|
|
|
if( my $links = $relationships{$key}{links} ) {
|
|
$s->{relationships}{$key}{links} = gen_links($links,$s->{relationships}{ $key }{data}, $extra_data );
|
|
}
|
|
|
|
push @$included, @inc if $included;
|
|
}
|
|
|
|
delete $s->{attributes} unless $s->{attributes}->%*;
|
|
|
|
if( $self->allowed_attributes ) {
|
|
delete $s->{attributes}{$_} for (
|
|
set( keys $s->{attributes}->%* ) - set($self->allowed_attributes->@* ) )->@*;
|
|
}
|
|
|
|
return $s;
|
|
|
|
}
|
|
|
|
sub obj_ref($data, $included) {
|
|
return [ map { obj_ref($_,$included) } @$data ] if ref $data eq 'ARRAY';
|
|
|
|
return $data if keys %$data == 2;
|
|
|
|
push @$included, $data;
|
|
|
|
return +{ $data->%{qw/ id type/} };
|
|
}
|
|
|
|
sub gen_id($self,$data) {
|
|
my $id = $self->id;
|
|
|
|
return ref $id ? $id->($data) : $data->{$id};
|
|
}
|
|
|
|
sub gen_links($links,$data,$extra_data={}) {
|
|
|
|
return $links->($data,$extra_data) if ref $links eq 'CODE';
|
|
|
|
return {
|
|
pairmap { $a => gen_item($b, $data,$extra_data) } %$links
|
|
};
|
|
}
|
|
|
|
sub gen_item($item,$data,$extra_data) {
|
|
return $item unless ref $item;
|
|
|
|
return $item->($data,$extra_data);
|
|
}
|
|
|
|
1;
|