Dancer2-Plugin-JsonApi/lib/Dancer2/Plugin/JsonApi/Registry/Schema.pm

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;