From 8639858b602dc42cea490deecec45faeca255553 Mon Sep 17 00:00:00 2001
From: Yanick Champoux <yanick@babyl.ca>
Date: Wed, 1 Nov 2023 13:16:34 -0400
Subject: [PATCH] relationships

---
 lib/Dancer2/Plugin/JsonApi/Registry.pm        |  1 +
 lib/Dancer2/Plugin/JsonApi/Registry/Schema.pm | 49 +++++++++++++++++--
 t/relationships.t                             | 46 +++++++++++++++++
 3 files changed, 92 insertions(+), 4 deletions(-)
 create mode 100644 t/relationships.t

diff --git a/lib/Dancer2/Plugin/JsonApi/Registry.pm b/lib/Dancer2/Plugin/JsonApi/Registry.pm
index b457d6c..92d8cb3 100644
--- a/lib/Dancer2/Plugin/JsonApi/Registry.pm
+++ b/lib/Dancer2/Plugin/JsonApi/Registry.pm
@@ -38,6 +38,7 @@ Adds a data type to the registry.
 
 sub add_type($self,$type,$definition={}) {
     $self->{types}{$type} = Dancer2::Plugin::JsonApi::Registry::Schema->new(
+        registry => $self,
         type => $type,
         %$definition
     );
diff --git a/lib/Dancer2/Plugin/JsonApi/Registry/Schema.pm b/lib/Dancer2/Plugin/JsonApi/Registry/Schema.pm
index 3261023..07183d3 100644
--- a/lib/Dancer2/Plugin/JsonApi/Registry/Schema.pm
+++ b/lib/Dancer2/Plugin/JsonApi/Registry/Schema.pm
@@ -35,6 +35,9 @@ has 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' );
 
 =head1 METHODS
 
@@ -51,15 +54,25 @@ sub serialize ( $self, $data, $extra_data = {} ) {
 
     $serial->{jsonapi} = { version => '1.0' };
 
-    $serial->{data} = $self->serialize_data($data,$extra_data);
+    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;
 
-    return $serial;
+    $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)
@@ -68,9 +81,9 @@ Serializes the inner C<$data>.
 
 =cut
 
-sub serialize_data ( $self, $data, $extra_data = {} ) {
+sub serialize_data ( $self, $data, $extra_data = {}, $included = undef ) {
 
-    return [ map { $self->serialize_data($_,$extra_data) } @$data ] if ref $data eq 'ARRAY';
+    return [ map { $self->serialize_data($_,$extra_data, $included) } @$data ] if ref $data eq 'ARRAY';
 
     my $s = {
         type => $self->type,
@@ -82,10 +95,38 @@ sub serialize_data ( $self, $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);
+
+        push @$included, @inc if $included;
+    }
+
+    delete $s->{attributes} unless $s->{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;
 
diff --git a/t/relationships.t b/t/relationships.t
new file mode 100644
index 0000000..b77ca38
--- /dev/null
+++ b/t/relationships.t
@@ -0,0 +1,46 @@
+use Test2::V0;
+
+use Dancer2::Plugin::JsonApi::Registry;
+
+use experimental qw/ signatures /;
+
+my $registry = Dancer2::Plugin::JsonApi::Registry->new;
+
+$registry->add_type( 'thing',
+    { relationships => { subthings => { type => 'subthing' }, } } );
+$registry->add_type('subthing');
+
+subtest basic => sub {
+    my $s = $registry->serialize(
+        'thing',
+        {   id        => 1,
+            subthings => [ { id => 2, x => 10 }, { id => 3 } ] } );
+
+    ok not $s->{data}{attributes};
+
+    like $s,
+      { data => {
+            id            => 1,
+            type          => 'thing',
+            relationships =>
+              { subthings => { data => [ { id => 2 }, { id => 3 } ] } }
+        },
+        included =>
+          [ { type => 'subthing', id => 2, attributes => { x => 10 } }, ] };
+
+};
+
+subtest "don't repeat includes" => sub {
+    my $s = $registry->serialize(
+        'thing', [
+        {   id        => 1,
+            subthings => [ { id => 2, x => 10 }, { id => 3, y => 20 } ] },
+        {   id        => 2,
+            subthings => [ { id => 3, y => 20 }, { id => 2, x => 10 } ] } 
+    ]
+);
+
+    is $s->{ included }->@* + 0, 2;
+};
+
+done_testing;