2023-10-31 19:41:10 +00:00
|
|
|
use 5.32.0;
|
|
|
|
|
2023-11-13 18:38:56 +00:00
|
|
|
package Dancer2::Plugin::JsonApi::Schema;
|
2023-10-31 19:41:10 +00:00
|
|
|
|
|
|
|
use Moo;
|
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
use experimental qw/ signatures /;
|
2023-10-31 20:45:42 +00:00
|
|
|
use List::AllUtils qw/ pairmap pairgrep /;
|
2023-10-31 19:41:10 +00:00
|
|
|
|
2023-11-01 20:03:28 +00:00
|
|
|
use Set::Object qw/set/;
|
|
|
|
|
2023-11-14 16:45:06 +00:00
|
|
|
has registry => ( is => 'ro' );
|
2023-10-31 19:41:10 +00:00
|
|
|
|
|
|
|
has type => (
|
|
|
|
required => 1,
|
|
|
|
is => 'ro',
|
|
|
|
);
|
|
|
|
|
|
|
|
has id => (
|
|
|
|
is => 'ro',
|
|
|
|
default => 'id'
|
|
|
|
);
|
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
has links => ( is => 'ro' );
|
|
|
|
has top_level_links => ( is => 'ro' );
|
|
|
|
has top_level_meta => ( is => 'ro' );
|
|
|
|
has relationships => ( is => 'ro', default => sub { +{} } );
|
2023-11-01 17:16:34 +00:00
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
has allowed_attributes => ( is => 'ro' );
|
2023-11-14 16:45:06 +00:00
|
|
|
has before_serialize => ( is => 'ro' );
|
2023-10-31 19:41:10 +00:00
|
|
|
|
2023-11-01 15:03:11 +00:00
|
|
|
sub serialize ( $self, $data, $extra_data = {} ) {
|
2023-10-31 19:41:10 +00:00
|
|
|
|
|
|
|
my $serial = {};
|
|
|
|
|
|
|
|
$serial->{jsonapi} = { version => '1.0' };
|
|
|
|
|
2023-11-01 17:16:34 +00:00
|
|
|
my @included;
|
|
|
|
|
2023-11-13 15:31:24 +00:00
|
|
|
if ( defined $data ) {
|
|
|
|
$serial->{data} =
|
|
|
|
$self->serialize_data( $data, $extra_data, \@included );
|
|
|
|
}
|
2023-10-31 19:41:10 +00:00
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
$serial->{links} = gen_links( $self->top_level_links, $data, $extra_data )
|
|
|
|
if $self->top_level_links;
|
2023-11-13 15:38:51 +00:00
|
|
|
|
|
|
|
if ( $self->registry and $self->registry->app ) {
|
|
|
|
$serial->{links}{self} = $self->registry->app->request->path;
|
|
|
|
}
|
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
$serial->{meta} = gen_links( $self->top_level_meta, $data, $extra_data )
|
|
|
|
if $self->top_level_meta;
|
2023-10-31 19:41:10 +00:00
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
$serial->{included} = [ dedupe_included(@included) ] if @included;
|
2023-11-01 17:16:34 +00:00
|
|
|
|
2023-10-31 19:41:10 +00:00
|
|
|
return $serial;
|
2023-11-01 17:16:34 +00:00
|
|
|
}
|
2023-10-31 19:41:10 +00:00
|
|
|
|
2023-11-01 17:16:34 +00:00
|
|
|
sub dedupe_included {
|
|
|
|
my %seen;
|
2023-11-13 14:49:27 +00:00
|
|
|
return grep { not $seen{ $_->{type} }{ $_->{id} }++ } @_;
|
2023-10-31 19:41:10 +00:00
|
|
|
}
|
|
|
|
|
2023-11-13 17:29:37 +00:00
|
|
|
has attributes => (
|
|
|
|
is => 'ro',
|
|
|
|
default => sub {
|
|
|
|
my $self = shift;
|
|
|
|
return sub {
|
|
|
|
my ( $data, $extra_data ) = @_;
|
|
|
|
return {} if ref $data ne 'HASH';
|
|
|
|
my @keys = grep { not $self->relationships->{$_} }
|
|
|
|
grep { $_ ne $self->id } keys %$data;
|
|
|
|
return { $data->%{@keys} };
|
|
|
|
}
|
|
|
|
}
|
|
|
|
);
|
|
|
|
|
2023-11-01 17:16:34 +00:00
|
|
|
sub serialize_data ( $self, $data, $extra_data = {}, $included = undef ) {
|
2023-10-31 19:41:10 +00:00
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
return [ map { $self->serialize_data( $_, $extra_data, $included ) }
|
|
|
|
@$data ]
|
|
|
|
if ref $data eq 'ARRAY';
|
2023-10-31 19:41:10 +00:00
|
|
|
|
2023-11-14 15:24:09 +00:00
|
|
|
if ( $self->before_serialize ) {
|
|
|
|
$data = $self->before_serialize->( $data, $extra_data );
|
|
|
|
}
|
|
|
|
|
2023-11-01 19:21:06 +00:00
|
|
|
# it's a scalar? it's the id
|
|
|
|
return { id => $data, type => $self->type } unless ref $data;
|
|
|
|
|
2023-10-31 19:41:10 +00:00
|
|
|
my $s = {
|
|
|
|
type => $self->type,
|
2023-11-13 18:12:48 +00:00
|
|
|
id => $self->gen_id( $data, $extra_data )
|
2023-11-13 14:49:27 +00:00
|
|
|
};
|
2023-10-31 19:41:10 +00:00
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
if ( $self->links ) {
|
|
|
|
$s->{links} = gen_links( $self->links, $data, $extra_data );
|
2023-10-31 19:41:10 +00:00
|
|
|
}
|
|
|
|
|
2023-11-13 17:29:37 +00:00
|
|
|
$s->{attributes} = gen_links( $self->attributes, $data, $extra_data );
|
2023-10-31 20:45:42 +00:00
|
|
|
|
2023-11-01 17:16:34 +00:00
|
|
|
my %relationships = $self->relationships->%*;
|
|
|
|
|
|
|
|
for my $key ( keys %relationships ) {
|
2023-11-13 17:29:37 +00:00
|
|
|
my $attr = $data->{$key};
|
2023-11-01 17:16:34 +00:00
|
|
|
|
|
|
|
my @inc;
|
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
my $t = $self->registry->serialize( $relationships{$key}{type},
|
|
|
|
$attr, \@inc );
|
2023-11-01 17:16:34 +00:00
|
|
|
|
2023-11-13 18:12:48 +00:00
|
|
|
if ( my $data = obj_ref( $t->{data}, \@inc ) ) {
|
|
|
|
$s->{relationships}{$key}{data} = $data;
|
|
|
|
}
|
2023-11-01 17:16:34 +00:00
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
if ( my $links = $relationships{$key}{links} ) {
|
|
|
|
$s->{relationships}{$key}{links} =
|
2023-11-13 18:12:48 +00:00
|
|
|
gen_links( $links, $data, $extra_data );
|
2023-11-01 21:39:15 +00:00
|
|
|
}
|
|
|
|
|
2023-11-01 17:16:34 +00:00
|
|
|
push @$included, @inc if $included;
|
|
|
|
}
|
|
|
|
|
|
|
|
delete $s->{attributes} unless $s->{attributes}->%*;
|
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
if ( $self->allowed_attributes ) {
|
|
|
|
delete $s->{attributes}{$_}
|
|
|
|
for ( set( keys $s->{attributes}->%* ) -
|
|
|
|
set( $self->allowed_attributes->@* ) )->@*;
|
2023-11-01 20:03:28 +00:00
|
|
|
}
|
|
|
|
|
2023-10-31 19:41:10 +00:00
|
|
|
return $s;
|
|
|
|
|
|
|
|
}
|
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
sub obj_ref ( $data, $included ) {
|
|
|
|
return [ map { obj_ref( $_, $included ) } @$data ]
|
|
|
|
if ref $data eq 'ARRAY';
|
2023-11-01 17:16:34 +00:00
|
|
|
|
|
|
|
return $data if keys %$data == 2;
|
|
|
|
|
2023-11-13 18:12:48 +00:00
|
|
|
return unless keys %$data;
|
|
|
|
|
2023-11-01 17:16:34 +00:00
|
|
|
push @$included, $data;
|
|
|
|
|
|
|
|
return +{ $data->%{qw/ id type/} };
|
|
|
|
}
|
|
|
|
|
2023-11-13 18:12:48 +00:00
|
|
|
sub gen_id ( $self, $data, $xtra ) {
|
2023-10-31 19:41:10 +00:00
|
|
|
my $id = $self->id;
|
|
|
|
|
2023-11-13 18:12:48 +00:00
|
|
|
return ref $id ? $id->( $data, $xtra ) : $data->{$id};
|
2023-10-31 19:41:10 +00:00
|
|
|
}
|
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
sub gen_links ( $links, $data, $extra_data = {} ) {
|
2023-10-31 19:41:10 +00:00
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
return $links->( $data, $extra_data ) if ref $links eq 'CODE';
|
2023-10-31 19:41:10 +00:00
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
return { pairmap { $a => gen_item( $b, $data, $extra_data ) } %$links };
|
2023-10-31 19:41:10 +00:00
|
|
|
}
|
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
sub gen_item ( $item, $data, $extra_data ) {
|
2023-10-31 19:41:10 +00:00
|
|
|
return $item unless ref $item;
|
|
|
|
|
2023-11-13 14:49:27 +00:00
|
|
|
return $item->( $data, $extra_data );
|
2023-10-31 19:41:10 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
1;
|