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

use 5.32.0;

package Dancer2::Plugin::JsonApi::Schema;

use Moo;

use experimental   qw/ signatures /;
use List::AllUtils qw/ pairmap pairgrep /;

use Set::Object qw/set/;

has registry => ( is => 'ro' );

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

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 allowed_attributes => ( is => 'ro' );
has before_serialize   => ( is => 'ro' );

sub serialize ( $self, $data, $extra_data = {} ) {

    my $serial = {};

    $serial->{jsonapi} = { version => '1.0' };

    my @included;

    if ( defined $data ) {
        $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;

    if ( $self->registry and $self->registry->app ) {
        $serial->{links}{self} = $self->registry->app->request->path;
    }

    $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} }++ } @_;
}

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} };
        }
    }
);

sub serialize_data ( $self, $data, $extra_data = {}, $included = undef ) {

    return [ map { $self->serialize_data( $_, $extra_data, $included ) }
          @$data ]
      if ref $data eq 'ARRAY';

    if ( $self->before_serialize ) {
        $data = $self->before_serialize->( $data, $extra_data );
    }

    # 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, $extra_data )
    };

    if ( $self->links ) {
        $s->{links} = gen_links( $self->links, $data, $extra_data );
    }

    $s->{attributes} = gen_links( $self->attributes, $data, $extra_data );

    my %relationships = $self->relationships->%*;

    for my $key ( keys %relationships ) {
        my $attr = $data->{$key};

        my @inc;

        my $t = $self->registry->serialize( $relationships{$key}{type},
            $attr, \@inc );

        if ( my $data = obj_ref( $t->{data}, \@inc ) ) {
            $s->{relationships}{$key}{data} = $data;
        }

        if ( my $links = $relationships{$key}{links} ) {
            $s->{relationships}{$key}{links} =
              gen_links( $links, $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;

    return unless keys %$data;

    push @$included, $data;

    return +{ $data->%{qw/ id type/} };
}

sub gen_id ( $self, $data, $xtra ) {
    my $id = $self->id;

    return ref $id ? $id->( $data, $xtra ) : $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 );
}

sub deserialize ( $self, $serialized, $included = [] ) {

    my $data     = $serialized->{data};
    my @included = ( ( $serialized->{included} // [] )->@*, @$included );

    return $self->deserialize_data( $data, \@included );
}

sub expand_object ( $obj, $included ) {

    if ( ref $obj eq 'ARRAY' ) {
        return [ map { expand_object( $_, $included ) } @$obj ];
    }

    for (@$included) {
        return $_ if $_->{type} eq $obj->{type} and $_->{id} eq $obj->{id};
    }

    return $obj;
}

sub deserialize_data ( $self, $data, $included ) {

    if ( ref $data eq 'ARRAY' ) {
        return [ map { $self->deserialize_data( $_, $included ) } @$data ];
    }

    my %obj = (
        ( $data->{attributes} // {} )->%*,
        pairmap {
            $a =>
              $self->registry->type( $self->relationships->{$a}{type} )
              ->deserialize_data( $b, $included )
          } pairmap { $a => expand_object( $b, $included ) }
          pairmap { $a => $b->{data} } ( $data->{relationships} // {} )->%*
    );

    my $id_key = $self->id;
    if ( !ref $id_key ) {
        $obj{$id_key} = $data->{id};
    }

    if ( $data->{type} eq 'photo' ) {

        #        die keys %$data;
    }

    if ( 1 == keys %obj and exists $obj{id} ) {
        return $data->{id};
    }

    return \%obj;
}

1;