Selaa lähdekoodia

Let a post type declare what it depends on, instead of hardcoding it

%enrich was a lexical hash in HTML.pm with exactly one entry, invoice.tx, doing
three unrelated jobs at once: fetch every entities post so the editor could
render a picker, resolve the payee/payor UUIDs into posts, and sum the line
items. Nothing about it was reachable from a post type's own definition, so a
wizard-built type could never depend on anything.

A type now says what it depends on in its sidecar. Properties gain a 'relation'
pseudo-type -- the same trick 'upload' already uses -- carrying the target type,
and a top-level x-tcms-relations table says what gets injected at render:
an entry naming a 'from' field resolves the UUID in it into that post, one
without gets every post of the target type. Those are the two cases the invoice
already needed, and now anything can ask for them.

Resolution happens in _enrich_post, wired into the same two sites %enrich was:
series() keyed on child_form so the editor picker has options, posts() keyed on
each post's own form. The per-type lookup is memoized for the whole page, which
retires the "probably a performance problem" TODO -- a page of 25 invoices used
to scan every entities post 25 times.

Invoice migrates onto it and %enrich is gone. Its price-summing is genuine
per-type computation rather than a relation, so it moves to Trog::Enrich::Invoice,
named from the sidecar and resolved with the same care a post's callback field
gets -- a sidecar naming an arbitrary sub is a privilege question. invoice.tx and
invoice_tofrom.tx are untouched, which is the evidence the generalization covers
the real case and not just the new one.

The wizard can build these: a field type of 'Another Post', a target type and a
one/all mode. The two new selects are always present and always submit, since
the server zips the param_* arrays positionally and a short row would shift
every row after it. A 'pick one' field generates an empty select filled by
GET /api/posts_of_form, so the picker can't go stale against a template that was
generated months earlier; an 'all of them' field generates no editor input at
all, because it isn't something the post stores.

Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01U3k2hhSZpcsoe6uBmhF9nB
George Baugh 2 kuukautta sitten
vanhempi
sitoutus
1e433be89d

+ 85 - 16
lib/Trog/DataModule.pm

@@ -394,22 +394,78 @@ picks the change up on its very next add() with no restart needed.
 
 =cut
 
+# Stat the forms dirs, not their parents -- writing blog.json bumps the mtime
+# of forms/, and nothing above it.  Both candidates, since either one gaining a
+# sidecar changes the answer.
+sub _sidecar_generation {
+    return join( ':', map { ( stat("$_/forms") )[9] // 0 } Trog::Themes::template_dirs( 'text/html', 1 ) );
+}
+
+# A signature default only covers an absent arg, and plenty of posts have an
+# explicitly undef form.
+sub _type_of ($form) {
+    $form = '' if !defined $form || ref $form;
+    my ($type) = $form =~ m/^([A-Za-z0-9_-]+)\.tx$/;
+    return $type // '';
+}
+
+=head2 type_meta_for($form)
+
+The parts of a post type's sidecar which aren't schema: x-tcms-relations,
+x-tcms-post-type and friends.
+
+schema_for() deliberately keeps only properties and required, since everything
+else would be noise to the validator -- but the relation tables and the post
+type's own metadata live out there and something has to read them.
+
+=cut
+
+sub type_meta_for ( $form = '' ) {
+    state %cache;
+
+    my $generation = _sidecar_generation();
+    %cache = () unless exists $cache{$generation};
+
+    my $type = _type_of($form);
+    return $cache{$generation}{$type} if exists $cache{$generation}{$type};
+
+    my $path = $type ? Trog::Themes::themed_file_in_dir( 'forms', "$type.json", 'text/html', 1 ) : undef;
+    my $sidecar = $path ? _read_sidecar($path) : undef;
+
+    my %meta;
+    if ($sidecar) {
+        %meta = map { $_ => $sidecar->{$_} } grep { $_ ne 'properties' && $_ ne 'required' && $_ ne 'type' } keys(%$sidecar);
+    }
+
+    $cache{$generation}{$type} = \%meta;
+    return $cache{$generation}{$type};
+}
+
+=head2 relations_for($form)
+
+The x-tcms-relations table for a post type, as a hashref keyed on the template
+variable the resolved posts land in.  Empty when the type declares none.
+
+Each entry is { form => 'other.tx', from => 'field_name' } -- 'from' naming the
+field holding a UUID to resolve, or absent to mean every post of that type.
+
+=cut
+
+sub relations_for ( $form = '' ) {
+    my $relations = type_meta_for($form)->{'x-tcms-relations'};
+    return {} unless Ref::Util::is_hashref($relations);
+    return $relations;
+}
+
 sub schema_for ( $form = '' ) {
     state %cache;
 
-    # Stat the forms dirs, not their parents -- writing blog.json bumps the
-    # mtime of forms/, and nothing above it.  Both candidates, since either one
-    # gaining a sidecar changes the answer.
-    my $generation = join( ':', map { ( stat("$_/forms") )[9] // 0 } Trog::Themes::template_dirs( 'text/html', 1 ) );
+    my $generation = _sidecar_generation();
 
     # Only ever keep the current generation around.
     %cache = () unless exists $cache{$generation};
 
-    # A signature default only covers an absent arg, and plenty of posts have
-    # an explicitly undef form.
-    $form = '' if !defined $form || ref $form;
-    my ($type) = $form =~ m/^([A-Za-z0-9_-]+)\.tx$/;
-    $type //= '';
+    my $type = _type_of($form);
     return $cache{$generation}{$type} if exists $cache{$generation}{$type};
 
     my %merged = ( %post_schema, properties => { %{ $post_schema{properties} } } );
@@ -451,28 +507,41 @@ sub _read_sidecar ($path) {
     }
     return undef unless Ref::Util::is_hashref($spec);
 
-    _expand_uploads($spec);
+    _expand_pseudo_types($spec);
     return $spec;
 }
 
+# A relation is stored as the referenced post's UUID, and resolved into the
+# post itself at render time -- see the x-tcms-relations table a sidecar
+# declares alongside it, and Trog::Routes::HTML::_enrich_post.  The pseudo-type
+# exists so a sidecar can say what a field *means* rather than just that it
+# happens to be a string.
+our %relation_schema = ( type => 'string' );
+
 # Sugar: a sidecar says {"type":"upload"} rather than spelling out the
 # string-or-hashref dance every upload field would otherwise need.  Uploads are
 # a hashref on the way in from the browser and the href string they became on
 # the way back out of the datastore.
-sub _expand_uploads ($node) {
+sub _expand_pseudo_types ($node) {
     return unless Ref::Util::is_hashref($node);
 
-    if ( ( $node->{type} // '' ) eq 'upload' ) {
+    my %pseudo = (
+        upload   => \%upload_schema,
+        relation => \%relation_schema,
+    );
+
+    my $type = $node->{type} // '';
+    if ( $pseudo{$type} ) {
         delete $node->{type};
-        %$node = ( %$node, %upload_schema );
+        %$node = ( %$node, %{ $pseudo{$type} } );
         return;
     }
 
-    _expand_uploads($_) foreach values( %{ $node->{properties} // {} } );
-    _expand_uploads( $node->{items} ) if $node->{items};
+    _expand_pseudo_types($_) foreach values( %{ $node->{properties} // {} } );
+    _expand_pseudo_types( $node->{items} ) if $node->{items};
     foreach my $key (qw{oneOf anyOf allOf}) {
         next unless Ref::Util::is_arrayref( $node->{$key} );
-        _expand_uploads($_) foreach @{ $node->{$key} };
+        _expand_pseudo_types($_) foreach @{ $node->{$key} };
     }
     return;
 }

+ 41 - 0
lib/Trog/Enrich/Invoice.pm

@@ -0,0 +1,41 @@
+package Trog::Enrich::Invoice;
+
+use strict;
+use warnings;
+
+no warnings 'experimental';
+use feature qw{signatures};
+
+use List::Util();
+
+=head1 Trog::Enrich::Invoice
+
+The part of an invoice which has to be computed rather than merely fetched.
+
+Its payee and payor are ordinary relations, declared in invoice.json and
+resolved by Trog::Routes::HTML::_enrich_post like any other type's.  The
+running total is not -- it is read out of the line items themselves.
+
+=head2 enrich($post, $query) = %extra
+
+Sum the line items into a total.  Each page of a multi-page invoice post is one
+line item, and a line beginning 'Price:' is what carries its cost; the
+denomination is taken from the first one that has any.
+
+=cut
+
+sub enrich ( $post, $query ) {
+    return () unless ref $post->{data} eq 'ARRAY';
+
+    my $denomination;
+    my @prices = map {
+        my $price = 0;
+        ( $denomination, $price ) = m/^Price:\s*(\D)(\d+)/mix;
+        $price;
+    } @{ $post->{data} };
+
+    $denomination //= '$';
+    return ( total => $denomination . ( List::Util::sum(@prices) // 0 ) );
+}
+
+1;

+ 146 - 45
lib/Trog/Routes/HTML.pm

@@ -1041,29 +1041,86 @@ sub post_delete ($query) {
     return $query->{tpsgi}->see_also( $query->{to} );
 }
 
-my %enrich = (
-    'invoice.tx' => sub {
-        my ($post,$query) = @_;
-        # TODO it's probably a performance problem doing this per post rather than only for the series entry
-        my %ret = ( entities => [ _post_helper({ form => 'entities.tx', visibility => 'public' }, [], $query->{user_acls}) ] );
-        return %ret unless ref $post->{data} eq 'ARRAY';
-
-        # Figure out the payee/payor
-        $ret{payee_entity} = List::Util::first { $_->{id} eq $post->{payee} } @{$ret{entities}};
-        $ret{payor_entity} = List::Util::first { $_->{id} eq $post->{payor} } @{$ret{entities}};
-
-        # Build total
-        my $denom;
-        my @prices = map {
-            my $price = 0;
-            ($denom, $price) = m/^Price:\s*(\D)(\d+)/mix;
-            $price;
-        } @{$post->{data}};
-        $denom //= '$';
-        $ret{total} = $denom.(List::Util::sum(@prices) // 0);
-        return %ret;
-    },
-);
+=head2 _enrich_post($post, $query, $cache)
+
+Resolve a post type's declared relations onto the post, and run its enrich sub
+if it has one.
+
+A type says what it depends on in its sidecar rather than in code here -- see
+Trog::DataModule::relations_for.  An entry naming a 'from' field resolves the
+UUID in that field into the post it refers to; one without gets every post of
+the target type, which is what an editor picker or a "show me all of these"
+display wants.
+
+$cache is a per-request memo of the per-type lookups.  Without it a page of
+invoices re-scans every entities post once per invoice.
+
+=cut
+
+sub _enrich_post ( $post, $query, $cache = {} ) {
+    return unless Ref::Util::is_hashref($post) && $post->{form};
+
+    my $relations = Trog::DataModule::relations_for( $post->{form} );
+    foreach my $as ( keys(%$relations) ) {
+        my $relation = $relations->{$as};
+        next unless Ref::Util::is_hashref($relation);
+
+        my ($target) = ( $relation->{form} // '' ) =~ m/^([A-Za-z0-9_-]+\.tx)$/;
+        next unless $target;
+
+        $cache->{$target} //= [ _post_helper( { form => $target }, [], $query->{user_acls} ) ];
+
+        # No 'from' means the relation is the whole set rather than one of them.
+        my $from = $relation->{from};
+        if ( !$from ) {
+            $post->{$as} = $cache->{$target};
+            next;
+        }
+
+        my $wanted = $post->{$from};
+        $post->{$as} = defined $wanted ? List::Util::first { $_->{id} eq $wanted } @{ $cache->{$target} } : undef;
+    }
+
+    _enrich_callback( $post, $query );
+    return;
+}
+
+# Anything a type needs computed rather than merely fetched.  The sub is named
+# in the sidecar, so validate it the same way a post's own callback field is --
+# a sidecar naming an arbitrary sub is a privilege question, not a typo.
+sub _enrich_callback ( $post, $query ) {
+    my $meta = Trog::DataModule::type_meta_for( $post->{form} );
+    my $sub  = $meta->{'x-tcms-post-type'}{enrich};
+    return unless $sub && !ref $sub;
+
+    my ($modname) = $sub =~ m/^([\w:]+)::\w+$/;
+    if ( !$modname ) {
+        WARN("Post type '$post->{form}' declares a malformed enrich sub '$sub'");
+        return;
+    }
+
+    my $modpath = $modname;
+    $modpath =~ s{::}{/}g;
+    $modpath .= '.pm';
+
+    local $@;
+    eval { require $modpath; 1 } or do {
+        WARN("Post type '$post->{form}' declares enrich sub '$sub', but $modname will not load: $@");
+        return;
+    };
+
+    no strict 'refs';
+    if ( !defined &{$sub} ) {
+        WARN("Post type '$post->{form}' declares enrich sub '$sub', which does not exist");
+        return;
+    }
+
+    my %extra = &{$sub}( $post, $query );
+    use strict;
+
+    @$post{ keys(%extra) } = values(%extra);
+    return;
+}
 
 =head2 series
 
@@ -1095,12 +1152,21 @@ sub series ($query) {
     #Grab the relevant tag (aclname), then pass that to posts
     my @posts = _post_helper( $query, ['series'], $query->{user_acls} );
 
-    # Enrich posts with additional data based on the template if necessary
-    if (exists $enrich{$posts[0]->{child_form}}) {
-        my $callback = $enrich{$posts[0]->{child_form}};
-        my %extra_data = $callback->($posts[0], $query);
-        foreach my $key (keys(%extra_data)) {
-            $posts[0]->{$key} = $extra_data{$key};
+    # The series post carries its *children's* relations, so that an editor
+    # picker rendered on this page has something to populate from -- that is
+    # what $primary_post.entities is on an invoice series.  Keyed on child_form
+    # rather than form: the series is a series.tx, its children are what
+    # declare the dependency.
+    if ( $posts[0] ) {
+        my $relations = Trog::DataModule::relations_for( $posts[0]{child_form} );
+        if (%$relations) {
+
+            # Resolve against a stand-in wearing the child's form, then copy
+            # only the relation keys back, so nothing else about the series
+            # post gets overwritten.
+            my $stand_in = { %{ $posts[0] }, form => $posts[0]{child_form} };
+            _enrich_post( $stand_in, $query );
+            @{ $posts[0] }{ keys(%$relations) } = @{$stand_in}{ keys(%$relations) };
         }
     }
 
@@ -1391,16 +1457,10 @@ sub posts ( $query, $direct = 0 ) {
     my $picker = Trog::Component::EmojiPicker::render();
     return $picker if ref $picker eq 'ARRAY';
 
-    # Enrich posts with additional data based on the template if necessary
-    foreach my $poast (@posts) {
-        if (exists $enrich{$poast->{form}}) {
-            my $callback = $enrich{$poast->{form}};
-            my %extra_data = $callback->($poast, $query);
-            foreach my $key (keys(%extra_data)) {
-                $poast->{$key} = $extra_data{$key};
-            }
-        }
-    }
+    # Resolve each post's declared relations.  One cache for the whole page, so
+    # 25 invoices don't mean 25 scans of every entities post.
+    my %relation_cache;
+    _enrich_post( $_, $query, \%relation_cache ) foreach @posts;
 
 
     #XXX the only reason this is needed is due to direct=1
@@ -1877,6 +1937,7 @@ our %wizard_checked_by_default = map { $_ => 1 } qw{wrapper inc_post_title inc_p
 # store an HTTP::Body::OctetStream that nothing ever picks up.  Point folks at
 # the attachment uploader instead.
 our %wizard_field_types = (
+    relation => { type => 'relation' },
     text     => { type => 'string' },
     url      => { type => 'string' },
     date     => { type => 'string' },
@@ -2065,6 +2126,8 @@ sub _wizard_fields ($query) {
     my $labels = Trog::Utils::coerce_array( $query->{param_label} );
     my $phs    = Trog::Utils::coerce_array( $query->{param_placeholder} );
     my $reqs   = Trog::Utils::coerce_array( $query->{param_required} );
+    my $rforms = Trog::Utils::coerce_array( $query->{param_relation_form} );
+    my $rmodes = Trog::Utils::coerce_array( $query->{param_relation_mode} );
 
     my ( @fields, %seen );
     foreach my $index ( 0 .. $#$names ) {
@@ -2081,14 +2144,22 @@ sub _wizard_fields ($query) {
         my $type = _wizard_scalar( $types->[$index] );
         $type = 'text' unless $wizard_field_types{$type};
 
+        # A relation is only a relation if it names a target type that looks
+        # like one; anything else falls back to being a plain text field.
+        my ($rform) = _wizard_scalar( $rforms->[$index] ) =~ m/^([A-Za-z0-9_-]+\.tx)$/;
+        my $rmode = _wizard_scalar( $rmodes->[$index] ) eq 'all' ? 'all' : 'one';
+        $type = 'text' if $type eq 'relation' && !$rform;
+
         push(
             @fields,
             {
-                name        => $fname,
-                type        => $type,
-                label       => _kolon_safe( $labels->[$index] ) || ucfirst($fname),
-                placeholder => _kolon_safe( $phs->[$index] ),
-                required    => _wizard_scalar( $reqs->[$index] ) ? 1 : 0,
+                name          => $fname,
+                type          => $type,
+                label         => _kolon_safe( $labels->[$index] ) || ucfirst($fname),
+                placeholder   => _kolon_safe( $phs->[$index] ),
+                required      => _wizard_scalar( $reqs->[$index] ) ? 1 : 0,
+                relation_form => $rform,
+                relation_mode => $rmode,
             }
         );
     }
@@ -2109,12 +2180,30 @@ sub _wizard_sidecar ( $name, $fields, $includes, $body_form ) {
     my %properties;
     my @required;
 
+    my %relations;
+
     foreach my $field (@$fields) {
+
+        # A relation pulling in every post of its target type isn't a field the
+        # post stores at all -- it is purely something injected at render, so
+        # it gets a relations entry and no property.
+        if ( $field->{type} eq 'relation' && $field->{relation_mode} eq 'all' ) {
+            $relations{ $field->{name} } = { form => $field->{relation_form} };
+            next;
+        }
+
         my $property = { %{ $wizard_field_types{ $field->{type} } } };
         $property->{'x-tcms-input'} = $field->{type};
         $property->{'x-tcms-label'} = $field->{label};
         $property->{'x-tcms-placeholder'} = $field->{placeholder} if length $field->{placeholder};
 
+        if ( $field->{type} eq 'relation' ) {
+            $property->{'x-tcms-relation-form'} = $field->{relation_form};
+
+            # The stored field holds a UUID; the resolved post lands beside it.
+            $relations{"$field->{name}_post"} = { form => $field->{relation_form}, from => $field->{name} };
+        }
+
         $properties{ $field->{name} } = $property;
         push( @required, $field->{name} ) if $field->{required};
     }
@@ -2130,7 +2219,8 @@ sub _wizard_sidecar ( $name, $fields, $includes, $body_form ) {
         type       => 'object',
         properties => \%properties,
     );
-    $spec{required} = \@required if @required;
+    $spec{required}            = \@required  if @required;
+    $spec{'x-tcms-relations'} = \%relations if %relations;
 
     return \%spec;
 }
@@ -2139,6 +2229,17 @@ sub _wizard_field_html ($field) {
     my ( $n, $t, $l, $p ) = @$field{qw{name type label placeholder}};
     my $required = $field->{required} ? 'required ' : '';
 
+    if ( $t eq 'relation' ) {
+
+        # 'all' relations aren't stored, so there is nothing to edit.
+        return '' if $field->{relation_mode} eq 'all';
+
+        # Left empty on purpose: post_relations.js fills it from
+        # /api/posts_of_form, so the picker can't go stale against the
+        # generated template.
+        return qq|            $l<br /><select ${required}class="cooltext relation-picker" name="$n" data-relation-form="$field->{relation_form}" data-selected="<: \$post.$n :>"></select>\n|;
+    }
+
     return qq|            $l<br /><textarea ${required}class="cooltext" name="$n" placeholder="$p"><: \$post.$n :></textarea>\n|
       if $t eq 'textarea';
 

+ 34 - 0
lib/Trog/Routes/JSON.pm

@@ -44,6 +44,17 @@ our %routes = (
         noindex    => 1,
         robot_name => '/api/auth_change_request/*',
     },
+    '/api/posts_of_form' => {
+        method     => 'GET',
+        auth       => 1,
+        parameters => {
+
+            # Same shape series.json demands of child_form.
+            form => sub { $_[0] =~ m/^[A-Za-z0-9_-]+\.tx$/ },
+        },
+        callback => \&posts_of_form,
+        noindex  => 1,
+    },
     '/api/requests_per' => {
         method     => 'GET',
         auth       => 1,
@@ -113,6 +124,29 @@ sub process_auth_change_request ($query) {
     );
 }
 
+=head2 posts_of_form
+
+Implements GET /api/posts_of_form.  Requires a login.
+
+The id and title of every post of the named type which the caller is allowed to
+see.  This is what fills a relation field's dropdown in the post editor -- see
+www/scripts/post_relations.js and the x-tcms-relations tables in the post type
+sidecars.
+
+Only id and title: the caller is populating a picker, and a post's body is
+nobody's business here.
+
+=cut
+
+sub posts_of_form ($query) {
+    my @posts = Trog::Routes::HTML::_post_helper( { form => $query->{form}, limit => 0 }, [], $query->{user_acls} );
+
+    return _render(
+        200, undef,
+        posts => [ map { { id => $_->{id}, title => $_->{title} } } @posts ],
+    );
+}
+
 sub requests_per ($query) {
     my $code = Trog::Utils::coerce_array( $query->{code} );
     return _render(

+ 152 - 2
t/Trog-Routes-HTML-series-lifecycle.t

@@ -26,6 +26,7 @@ use File::Path     ();
 use File::Temp     ();
 use Time::HiRes    ();
 use URI::Escape    ();
+use JSON::MaybeXS  ();
 
 our ( $REPO, $ROOT, $OLDCWD );
 our %REPO_BEFORE;
@@ -137,6 +138,7 @@ require Trog::Data;
 require Trog::Auth;
 require Trog::SQLite::TagIndex;
 require Trog::Routes::HTML;
+require Trog::Routes::JSON;
 
 #--------------------------------------------------------------------------
 # A stand-in for the tPSGI object the router injects as $query->{tpsgi}.
@@ -416,6 +418,12 @@ subtest 'the post wizard invents a new post type' => sub {
     # This is the assertion that the sandbox is real: a symlinked template tree
     # would have put these in the developer's actual checkout.
     ok( !-e "$REPO/www/templates/html/components/forms/spec_widget.tx", 'nothing was written into the repo' );
+
+    # The relation controls have to be present in every row and always submit,
+    # or the parallel param_* arrays de-align server side.
+    like( $body, qr/name="param_relation_form"/, 'the relation target select is in the row template' );
+    like( $body, qr/name="param_relation_mode"/, 'so is the relation mode select' );
+    like( $body, qr/<option value="relation">/,  'and relation is offered as a field type' );
 };
 
 #--------------------------------------------------------------------------
@@ -432,7 +440,11 @@ subtest 'the post wizard invents a new post type' => sub {
 #--------------------------------------------------------------------------
 
 sub _make_series {
-    my ( $label, $aclname, $child_form, $title ) = @_;
+    my ( $label, $aclname, $child_form, $title, %opt ) = @_;
+
+    # _get_series caps the bar at 10 and the seeds already use two, so only the
+    # series whose topbar behaviour we actually care about get tagged.
+    my @tags = $opt{no_topbar} ? ('series') : ( 'series', 'topbar' );
 
     my $series = _save_post(
         "$label series",
@@ -445,11 +457,13 @@ sub _make_series {
         data       => "$title subhead",
         callback   => 'Trog::Routes::HTML::series',
         visibility => 'public',
-        tags       => [ 'series', 'topbar' ],
+        tags       => \@tags,
         tiled      => 0,
         to         => '/',
     ) or return undef;
 
+    return $series if $opt{no_topbar};
+
     # The topbar comes from _get_series(), which index() renders through
     # categories.tx.  Check it on / -- the series has no children yet, and
     # posts() 404s on an empty series.
@@ -689,6 +703,142 @@ subtest 'spec_widget (the wizard-built type)' => sub {
     like( $body, qr/Spec widget body\./, 'and the body came through the generated template' );
 };
 
+subtest 'a wizard-built type can depend on another type' => sub {
+
+    # The type we will point at.  The relation is what is under test, so keep
+    # the target itself boring.
+    my ( $code, $body, $err ) = _render(
+        _admin(
+            route           => '/admin/wyzzerdd/save',
+            method          => 'POST',
+            name            => 'spec_target',
+            body_form       => 'form_common.tx',
+            wrapper         => 1,
+            inc_post_title  => 1,
+            inc_title_input => 1,
+            inc_visibility  => 1,
+            inc_tags        => 1,
+            display         => q{<div><: render_it($post.data) | mark_raw :></div>},
+        ),
+        \&Trog::Routes::HTML::post_wizard_save,
+    );
+    is( $code, 200, 'target type created' ) or diag($err);
+
+    # ...and the type that depends on it: one picked by id, one pulling in the
+    # whole set.
+    ( $code, $body, $err ) = _render(
+        _admin(
+            route               => '/admin/wyzzerdd/save',
+            method              => 'POST',
+            name                => 'spec_relator',
+            body_form           => 'form_common.tx',
+            wrapper             => 1,
+            inc_post_title      => 1,
+            inc_title_input     => 1,
+            inc_visibility      => 1,
+            inc_tags            => 1,
+            param_name          => [ 'chosen',       'everything' ],
+            param_type          => [ 'relation',     'relation' ],
+            param_label         => [ 'Chosen One',   'All Of Them' ],
+            param_placeholder   => [ '',             '' ],
+            param_required      => [ 0,              0 ],
+            param_relation_form => [ 'spec_target.tx', 'spec_target.tx' ],
+            param_relation_mode => [ 'one',          'all' ],
+            display             => q{<div class="rel"><span class="chosen"><: $post.chosen_post.title :></span>}
+              . q{<: for $post.everything -> $t { :><span class="each"><: $t.title :></span><: } :></div>},
+        ),
+        \&Trog::Routes::HTML::post_wizard_save,
+    );
+    is( $code, 200, 'relating type created' ) or diag($err);
+
+    my $sidecar = JSON::MaybeXS::decode_json(
+        Path::Tiny->new('www/templates/html/components/forms/spec_relator.json')->slurp_utf8 );
+
+    # 'one' is a field the post stores; 'all' is not a field at all.
+    is( $sidecar->{properties}{chosen}{type}, 'relation', 'the picked relation is a stored property' );
+    is( $sidecar->{properties}{chosen}{'x-tcms-relation-form'}, 'spec_target.tx', 'naming its target type' );
+    ok( !exists $sidecar->{properties}{everything}, "the 'all' relation stores nothing" );
+
+    is_deeply(
+        $sidecar->{'x-tcms-relations'},
+        {
+            chosen_post => { form => 'spec_target.tx', from => 'chosen' },
+            everything  => { form => 'spec_target.tx' },
+        },
+        'and both are declared for resolution at render'
+    );
+
+    # The relation pseudo-type has to become a real one before validation, or
+    # every relation field would be stripped as an unknown type.
+    is( Trog::DataModule::schema_for('spec_relator.tx')->{properties}{chosen}{type},
+        'string', "'relation' expands to a real schema type" );
+
+    _reindex();
+
+    # Now exercise it end to end.
+    _make_series( 'spec_target', 'spectarget', 'spec_target.tx', 'Spec Target Series', no_topbar => 1 ) or return;
+    my $target = _save_post(
+        'spec_target child',
+        form       => 'spec_target.tx',
+        title      => 'Spec Target Post',
+        data       => 'Spec target body.',
+        visibility => 'public',
+        tags       => ['spectarget'],
+        to         => '/spectarget',
+    ) or return;
+
+    _make_series( 'spec_relator', 'specrelator', 'spec_relator.tx', 'Spec Relator Series', no_topbar => 1 ) or return;
+    my $relator = _save_post(
+        'spec_relator child',
+        form       => 'spec_relator.tx',
+        title      => 'Spec Relator Post',
+        data       => 'Spec relator body.',
+        chosen     => $target->{id},
+        visibility => 'public',
+        tags       => ['specrelator'],
+        to         => '/specrelator',
+    ) or return;
+
+    is( $relator->{chosen}, $target->{id}, 'the referenced id survived validation' );
+
+    my $page = _series_page( 'spec_relator', 'specrelator', 'Spec Relator Series', 1 ) or return;
+
+    # Both halves of the relation resolved: the one we picked, and the set.
+    like( $page, qr{<span class="chosen">Spec Target Post</span>}, 'the picked post resolved into the page' );
+    like( $page, qr{<span class="each">Spec Target Post</span>},   'and so did the whole set' );
+};
+
+subtest '/api/posts_of_form feeds the relation picker' => sub {
+    my $target = _find_post('Spec Target Post');
+    ok( $target, 'the target post is there to be listed' ) or return;
+
+    my $res = Trog::Routes::JSON::posts_of_form( _admin( route => '/api/posts_of_form', form => 'spec_target.tx' ) );
+    is( ref $res, 'ARRAY', 'a PSGI response came back' ) or return;
+
+    my ( $code, undef, $body ) = @$res;
+    is( $code, 200, 'and it is a 200' );
+
+    my $payload = JSON::MaybeXS::decode_json( join( '', @$body ) );
+    is_deeply(
+        $payload->{posts},
+        [ { id => $target->{id}, title => 'Spec Target Post' } ],
+        'listing exactly the posts of that type, id and title only'
+    );
+
+    # An unknown type is an empty list, not an error -- a type with no posts
+    # yet is the normal state of affairs right after you create it.
+    $res = Trog::Routes::JSON::posts_of_form( _admin( route => '/api/posts_of_form', form => 'nosuchtype.tx' ) );
+    $payload = JSON::MaybeXS::decode_json( join( '', @{ $res->[2] } ) );
+    is_deeply( $payload->{posts}, [], 'an unknown type lists nothing rather than failing' );
+
+    # The route's own declaration is what keeps a malformed form out; check it
+    # matches what series.json demands of child_form.
+    my $validator = $Trog::Routes::JSON::routes{'/api/posts_of_form'}{parameters}{form};
+    ok( $validator->('blog.tx'), 'the parameter validator accepts a form name' );
+    ok( !$validator->('../../etc/passwd'), 'and rejects a path' );
+    ok( $Trog::Routes::JSON::routes{'/api/posts_of_form'}{auth}, 'the route requires a login' );
+};
+
 subtest 'saves report back through the jsalert banner' => sub {
 
     # A good save redirects to where you came from, carrying the outcome.

+ 50 - 0
www/scripts/post_relations.js

@@ -0,0 +1,50 @@
+// Fills in the dropdowns for relation fields -- the ones a post type declares
+// when it depends on posts of another type.
+//
+// The options are fetched rather than baked into the generated template so the
+// picker can't go stale: posts of the target type come and go long after the
+// type itself was written.  Auth rides the tcmslogin cookie, so a same origin
+// request needs nothing else.
+
+function populateRelationPicker(select) {
+    var form = select.getAttribute('data-relation-form');
+    if (!form) {
+        return;
+    }
+
+    var req = new XMLHttpRequest();
+    req.addEventListener("load", function () {
+        var payload;
+        try {
+            payload = JSON.parse(this.responseText);
+        } catch (e) {
+            console.log('could not read the post list for ' + form + ': ' + e);
+            return;
+        }
+
+        var selected = select.getAttribute('data-selected') || '';
+
+        // A relation that isn't required needs a way to say "none".
+        if (!select.required) {
+            select.appendChild(new Option('(none)', ''));
+        }
+
+        for (var post of payload.posts || []) {
+            var option = new Option(post.title, post.id);
+            option.selected = post.id === selected;
+            select.appendChild(option);
+        }
+    });
+    req.addEventListener("error", function () {
+        console.log('could not fetch the post list for ' + form);
+    });
+    req.open("GET", "/api/posts_of_form?form=" + encodeURIComponent(form));
+    req.send();
+}
+
+document.addEventListener("DOMContentLoaded", function(event) {
+    var pickers = document.querySelectorAll('select.relation-picker');
+    for (var picker of pickers) {
+        populateRelationPicker(picker);
+    }
+});

+ 26 - 0
www/scripts/post_wizard.js

@@ -13,6 +13,32 @@ function addParam() {
         return false;
     }
     host.appendChild(document.importNode(tpl.content, true));
+
+    // The row we just added is the last one; set its relation controls to
+    // match whatever its type select says.
+    var rows = host.querySelectorAll('.wizard-param-row');
+    if (rows.length) {
+        var added = rows[rows.length - 1].querySelector('.param-type');
+        if (added) {
+            syncRelationRow(added);
+        }
+    }
+    return false;
+}
+
+// The relation selects are only meaningful for a relation field, but they must
+// stay in the DOM and keep submitting whatever the type is -- the server zips
+// the param_* arrays together positionally, so a row that submits fewer values
+// than its neighbours shifts every row after it.  Hide, never remove.
+function syncRelationRow(select) {
+    var row = select.closest('.wizard-param-row');
+    if (!row) {
+        return false;
+    }
+    var relation = row.querySelector('.wizard-relation');
+    if (relation) {
+        relation.style.display = select.value === 'relation' ? '' : 'none';
+    }
     return false;
 }
 

+ 41 - 25
www/templates/html/components/forms/invoice.json

@@ -1,33 +1,49 @@
 {
-   "x-tcms-post-type" : {
-      "name" : "invoice",
-      "generated" : false,
-      "description" : "A multi-page invoice drawn between two entity posts."
-   },
-   "type" : "object",
-   "properties" : {
-      "preview" : {
-         "type" : "string",
-         "x-tcms-label" : "Preview Image"
+   "properties": {
+      "due_days": {
+         "minimum": 0,
+         "type": "integer",
+         "x-tcms-input": "number",
+         "x-tcms-label": "Due in (days)"
+      },
+      "payee": {
+         "type": "relation",
+         "x-tcms-label": "Payee",
+         "x-tcms-relation-form": "entities.tx"
+      },
+      "payor": {
+         "type": "relation",
+         "x-tcms-label": "Payor",
+         "x-tcms-relation-form": "entities.tx"
       },
-      "preview_file" : {
-         "type" : "upload",
-         "x-tcms-label" : "Preview Image",
-         "x-tcms-input" : "file"
+      "preview": {
+         "type": "string",
+         "x-tcms-label": "Preview Image"
       },
-      "payee" : {
-         "type" : "string",
-         "x-tcms-label" : "Payee"
+      "preview_file": {
+         "type": "upload",
+         "x-tcms-input": "file",
+         "x-tcms-label": "Preview Image"
+      }
+   },
+   "type": "object",
+   "x-tcms-post-type": {
+      "description": "A multi-page invoice drawn between two entity posts.",
+      "enrich": "Trog::Enrich::Invoice::enrich",
+      "generated": false,
+      "name": "invoice"
+   },
+   "x-tcms-relations": {
+      "entities": {
+         "form": "entities.tx"
       },
-      "payor" : {
-         "type" : "string",
-         "x-tcms-label" : "Payor"
+      "payee_entity": {
+         "form": "entities.tx",
+         "from": "payee"
       },
-      "due_days" : {
-         "type" : "integer",
-         "minimum" : 0,
-         "x-tcms-label" : "Due in (days)",
-         "x-tcms-input" : "number"
+      "payor_entity": {
+         "form": "entities.tx",
+         "from": "payor"
       }
    }
 }

+ 19 - 1
www/templates/html/components/post_wizard.tx

@@ -54,6 +54,12 @@ any custom fields, so that the data model knows to keep them when a post is save
     These become extra inputs in the editor, and are available in your display template below
     as <code>&lt;: $post.your_field_name :&gt;</code>.
     Uploads aren't supported here &mdash; use the Attachment uploader above for those.
+    <br />
+    An <em>Another Post</em> field depends on a different post type.
+    <em>Pick one</em> stores a single post's ID, chosen from a dropdown in the editor, and hands you
+    the whole post as <code>&lt;: $post.your_field_name_post :&gt;</code>.
+    <em>All of them</em> stores nothing and simply hands you every post of that type as
+    <code>&lt;: $post.your_field_name :&gt;</code> to loop over.
     <div id="wizard-params"></div>
     <button type="button" style="float:right;" class="coolbutton" onclick="addParam(); return false;">Add Field</button>
     <br style="clear:both;" />
@@ -76,14 +82,26 @@ any custom fields, so that the data model knows to keep them when a post is save
     <div class="wizard-param-row">
         <hr />
         Name <input required class="cooltext" type="text" name="param_name" pattern="[A-Za-z][A-Za-z0-9_]*" placeholder="cook_time" />
-        Type <select class="cooltext" name="param_type">
+        Type <select class="cooltext param-type" name="param_type" onchange="syncRelationRow(this);">
             <option value="text">Text</option>
             <option value="url">URL</option>
             <option value="number">Number</option>
             <option value="date">Date</option>
             <option value="textarea">Long Text</option>
             <option value="checkbox">Checkbox</option>
+            <option value="relation">Another Post</option>
         </select>
+        <span class="wizard-relation" style="display:none;">
+            of type <select class="cooltext" name="param_relation_form">
+: for $forms -> $form {
+                <option value="<: $form :>"><: $form :></option>
+: }
+            </select>
+            <select class="cooltext" name="param_relation_mode">
+                <option value="one">pick one</option>
+                <option value="all">all of them</option>
+            </select>
+        </span>
         Label <input class="cooltext" type="text" name="param_label" placeholder="Cook Time" />
         Placeholder <input class="cooltext" type="text" name="param_placeholder" placeholder="45 minutes" />
         <select class="cooltext" name="param_required">

+ 1 - 0
www/templates/html/components/posts.tx

@@ -1,5 +1,6 @@
 : if ( $can_edit ) {
     <script type="text/javascript" src="/scripts/post.js"></script>
+    <script type="text/javascript" src="/scripts/post_relations.js"></script>
     <div id="emoji_picker_modal" class="modal" style="display:none;">
     <: $emoji_picker | mark_raw :>
     </div>