New post type wizard done, along with other fixes

Mostly vibecoded with claude

Makefile.PL

@@ -38,6 +38,7 @@ WriteMakefile(
     'IO::Compress::Gzip'     => '0',
     'Imager::QRCode'         => '0',
     'JSON::MaybeXS'          => '0',
+    'JSON::Validator::Schema::Troglodyne' => '0',
     'List::Util'             => '0',
     'Mojo::File'             => '0',
     'POSIX'                  => '0',

bin/tcms-useradd

@@ -11,6 +11,7 @@ use Pod::Usage;
 use List::Util qw{first};
 
 use Trog::Auth;
+use Trog::Log;
 use Trog::Data;
 use Trog::Config;
 
@@ -19,9 +20,13 @@ $ENV{NOHUP} = 1;
 
 =head1 SYNOPSIS
 
-Add or edit a tCMS user.  In the event of a user edit, every option save for user is optional.
+Add or edit a tCMS user.  In the event of a user edit, every option save for user is optional,
+and the ones you leave out keep whatever value they already had.
 
-does not update user pages.  Use this to reset user passwords or fix broken users.
+Creating a user who does not exist yet needs --password, --display_name and --contact_email,
+as there is no existing profile post to inherit them from.
+
+Use this to reset user passwords or fix broken users.
 
 =head2 USAGE
 
@@ -37,7 +42,20 @@ Specify the user to add, or edit if the user already exists.
 
 =item --password
 
-Set a password for the user.  Leave blank if you want to keep the password for an existing user.
+Set a password for the user.  Omit the option entirely if you want to keep the
+password an existing user already has.
+
+Passing --password with no value prompts for one instead, with echo off, which
+keeps it out of your shell history and off your screen:
+
+    tcms-useradd --user foo --password           # prompts, twice, to confirm
+
+It can also be piped in, in which case it is read once and not confirmed:
+
+    echo hunter2 | tcms-useradd --user foo --password
+
+Note that setting a password kills any session the user currently holds, so
+they will have to log back in.
 
 =item --display_name
 
@@ -60,6 +78,53 @@ Display this output.
 
 =cut
 
+# The logger is set up per-request by the server; a CLI run has to do it itself,
+# or the first thing Trog::Auth logs blows up on an undefined $log.
+sub _init_logs {
+    my ($who) = @_;
+    Trog::Log::log_init( 'logs/tcms.log', 'info' );
+    $Trog::Log::user = $who // 'nobody';
+    return;
+}
+
+# Read a password off the terminal without echoing it, so it stays out of the
+# shell history and off the screen.  Falls back to a plain read when we aren't
+# on a TTY, which is what makes `echo hunter2 | tcms-useradd ...` work.
+sub _read_password {
+    my ($prompt) = @_;
+    my $password;
+    if ( -t STDIN ) {
+        print STDERR $prompt;
+        require Term::ReadKey;
+        Term::ReadKey::ReadMode('noecho');
+        $password = <STDIN>;
+        Term::ReadKey::ReadMode('restore');
+        print STDERR "\n";
+    }
+    else {
+        $password = <STDIN>;
+    }
+    chomp $password if defined $password;
+    return $password;
+}
+
+# What a brand new user's profile post looks like before we merge anything over
+# the top of it.  Mirrors what setup() builds for the very first user.
+sub _default_user_post {
+    return {
+        data       => 'Default user',
+        preview    => '/img/avatar/humm.gif',
+        wallpaper  => '/img/sys/testpattern.jpg',
+        tags       => ['about'],
+        visibility => 'public',
+        acls       => ['admin'],
+        callback   => 'Trog::Routes::HTML::users',
+        method     => 'GET',
+        form       => 'profile.tx',
+        aliases    => [],
+    };
+}
+
 sub main {
     my %options;
     Getopt::Long::GetOptionsFromArray(
@@ -67,40 +132,95 @@ sub main {
         'user=s'          => \$options{user},
         'display_name=s'  => \$options{display_name},
         'help|?'          => \$options{help},
-        'password=s'      => \$options{password},
+        'password:s'      => \$options{password},
         'contact_email=s' => \$options{contact_email},
         'acl=s@'          => \$options{acl},
     );
     pod2usage( -exitval => 0, -verbose => 1 ) if $options{help};
 
+    unless ( $options{user} ) {
+        print STDERR "--user is required.\n";
+        return 2;
+    }
+
+    # --password with no value means "ask me", as opposed to leaving the option
+    # out entirely, which means "leave the password alone".
+    if ( defined $options{password} && !length $options{password} ) {
+        my $interactive = -t STDIN;
+        $options{password} = _read_password("New password for '$options{user}': ");
+
+        unless ( defined $options{password} && length $options{password} ) {
+            print STDERR "No password provided.\n";
+            return 2;
+        }
+
+        # Only worth confirming when a human is typing it.  Piped input has no
+        # second line to read, and typos in a script aren't fixed by asking twice.
+        if ($interactive) {
+            my $again = _read_password("Confirm: ");
+            unless ( defined $again && $options{password} eq $again ) {
+                print STDERR "Passwords did not match.\n";
+                return 2;
+            }
+        }
+    }
+
     $options{acl} //= [];
     $options{acl} = [ $options{acl} ] if $options{acl} && ref $options{acl} ne 'ARRAY';
     $options{acl} = ['admin'] unless @{ $options{acl} };
 
-    Trog::Auth::killsession( $options{user} );
-    eval { Trog::Auth::useradd( $options{user}, $options{display_name}, $options{password}, $options{acl}, $options{contact_email} ) } or do {
-        return 1;
-    };
+    _init_logs( $options{user} );
 
-    # Find the user's post and edit it
+    # Find the user's existing post, if they have one.
     my $conf = Trog::Config::get();
     my $data = Trog::Data->new($conf);
 
     my @userposts = $data->get( tags => ['about'], acls => [qw{admin}] );
     my $user_obj  = first { ( $_->{user} || '' ) eq $options{user} } @userposts;
-    my %merged    = (
+
+    # A user we've never seen before has no post to edit, so start from the
+    # defaults rather than dereferencing undef.
+    my $is_new = !$user_obj;
+    $user_obj //= _default_user_post();
+
+    if ($is_new) {
+        unless ( $options{password} && $options{display_name} && $options{contact_email} ) {
+            print STDERR "User '$options{user}' does not exist yet.\n";
+            print STDERR "Creating one needs --password, --display_name and --contact_email.\n";
+            return 2;
+        }
+    }
+
+    # Only the options actually passed should win.  Merging %options wholesale
+    # writes an undef over every field the caller didn't mention, which is how
+    # resetting a password used to blank out the display name and contact email.
+    my %provided = map { $_ => $options{$_} } grep { defined $options{$_} } qw{user display_name contact_email};
+
+    my %merged = (
         %$user_obj,
-        %options,
-        $options{display_name} ? ( local_href => "/users/$options{display_name}" ) : ( local_href => $user_obj->{local_href} ),
+        %provided,
     );
 
-    # We don't want the password in plain text
-    delete $merged{password};
+    # The display name is the title of the post, and the URL it lives at.
+    $merged{title}      = $merged{display_name}          if $merged{display_name};
+    $merged{local_href} = "/users/$merged{display_name}" if $merged{display_name};
+
+    Trog::Auth::killsession( $options{user} );
+
+    local $@;
+    eval { Trog::Auth::useradd( $options{user}, $merged{display_name}, $options{password}, $options{acl}, $merged{contact_email} ); 1 } or do {
+        print STDERR "Could not add user '$options{user}': $@";
+        return 1;
+    };
 
-    # The ACLs a user posesses is not necessarily what ACLs you need to view or edit a user's profile.
-    delete $merged{acl};
+    eval { $data->add( \%merged ); 1 } or do {
+        my @errors = ref $@ eq 'ARRAY' ? @{$@} : ($@);
+        print STDERR "Saved the credentials for '$options{user}', but their profile post was rejected:\n";
+        print STDERR join( "\n", @errors ), "\n";
+        return 1;
+    };
 
-    $data->add( \%merged );
+    print "@{[ $is_new ? 'Added' : 'Updated' ]} user '$options{user}'.\n";
     return 0;
 }
 

bin/tcmslogin

@@ -0,0 +1,140 @@
+#!/usr/bin/env perl
+
+package tcms::login;
+
+use strict;
+use warnings;
+
+use FindBin::libs;
+use Getopt::Long;
+use Pod::Usage;
+
+use Trog::Auth;
+use Trog::Log;
+
+# Don't murder our terminal when done
+$ENV{NOHUP} = 1;
+
+=head1 SYNOPSIS
+
+Log a user in and print the resulting session cookie, so that you can hand it
+to call.pl and exercise authenticated routes without a browser.
+
+=head2 USAGE
+
+    tcmslogin --user foo --password bar
+
+    # Which is meant to be used like this:
+    call.pl GET /admin/wyzzerdd '' "$(tcmslogin --user foo --password bar)"
+
+The cookie is printed to STDOUT and nothing else is, so it is safe to capture.
+Everything else the script has to say goes to STDERR.
+
+Note that logging in wastes any session the user already holds -- the session
+table keeps one row per user -- so running this will log that user out of their
+browser.
+
+=head2 OPTIONS
+
+=over 4
+
+=item --user
+
+The user to log in.  Required.
+
+=item --password
+
+That user's password.  Leaving the option out, or passing it with no value,
+reads it from STDIN instead, which keeps it out of your shell history:
+
+    tcmslogin --user foo             # prompts, with echo off
+    tcmslogin --user foo --password  # same
+    echo hunter2 | tcmslogin --user foo
+
+=item --token
+
+The user's current TOTP code, if they have 2FA enabled.
+
+=item --raw
+
+Print just the session id, without the C<tcmslogin=> prefix.
+
+=item --help, --man
+
+Display this output.
+
+=back
+
+=cut
+
+# The logger is set up per-request by the server; a CLI run has to do it itself,
+# or the first thing Trog::Auth logs blows up on an undefined $log.
+sub _init_logs {
+    my ($who) = @_;
+    Trog::Log::log_init( 'logs/tcms.log', 'info' );
+    $Trog::Log::user = $who // 'nobody';
+    return;
+}
+
+sub _read_password {
+    my ($prompt) = @_;
+    my $password;
+    if ( -t STDIN ) {
+        print STDERR $prompt;
+        require Term::ReadKey;
+        Term::ReadKey::ReadMode('noecho');
+        $password = <STDIN>;
+        Term::ReadKey::ReadMode('restore');
+        print STDERR "\n";
+    }
+    else {
+        $password = <STDIN>;
+    }
+    chomp $password if defined $password;
+    return $password;
+}
+
+sub main {
+    my %options;
+    Getopt::Long::GetOptionsFromArray(
+        \@_,
+        'user=s'     => \$options{user},
+        'password:s' => \$options{password},
+        'token=s'    => \$options{token},
+        'raw'        => \$options{raw},
+        'help|?'     => \$options{help},
+    );
+    pod2usage( -exitval => 0, -verbose => 1 ) if $options{help};
+
+    unless ( $options{user} ) {
+        print STDERR "--user is required.\n";
+        return 2;
+    }
+
+    _init_logs( $options{user} );
+
+    # Omitted entirely or passed with no value both mean "ask me".
+    $options{password} = _read_password("Password for '$options{user}': ")
+      unless defined $options{password} && length $options{password};
+    unless ( defined $options{password} && length $options{password} ) {
+        print STDERR "No password provided.\n";
+        return 2;
+    }
+
+    # mksession() tells us nothing about *why* it said no, by design -- it is
+    # the same '' for an unknown user, a bad password and a bad TOTP code.
+    my $session = Trog::Auth::mksession( $options{user}, $options{password}, $options{token}, 'tcmslogin' );
+    unless ($session) {
+        print STDERR "Login failed for '$options{user}'.\n";
+        print STDERR "Check the password, and pass --token if this user has 2FA enabled.\n";
+        print STDERR "Use bin/tcms-useradd --user $options{user} --password ... to reset it.\n";
+        return 1;
+    }
+
+    print $options{raw} ? "$session\n" : "tcmslogin=$session\n";
+    return 0;
+}
+
+exit main(@ARGV) unless caller;
+
+1;

lib/Trog/DataModule.pm

@@ -10,13 +10,18 @@ use File::Copy;
 use Path::Tiny();
 use Ref::Util();
 use File::Basename qw{basename};
+use File::Slurper();
+use JSON::MaybeXS();
+use JSON::Validator::Schema::Troglodyne();
+
+use Trog::Themes();
 
 use Trog::Log qw{:all};
 use Trog::Utils;
 use Trog::Auth();
 
 no warnings 'experimental';
-use feature qw{signatures};
+use feature qw{signatures state};
 
 =head1 QUERY FORMAT
 
@@ -50,6 +55,38 @@ sub new ( $class, $config ) {
     return bless( $config, $class );
 }
 
+=head1 ABSTRACT METHODS
+
+Subclasses must implement all of these; the stubs here do nothing but die.
+count() belongs to this set as well, and is documented with the rest of the
+querying interface below.
+
+=head2 lang() = STRING $language
+
+The name of the query language this data model understands, shown to the user
+beside the search bar.
+
+=head2 help() = STRING $help
+
+Documentation for that query language, shown to the user alongside it.
+
+=head2 read($query) = ARRAYREF $posts
+
+Every post the data model holds, as an arrayref of hashrefs.  Filtering is
+get()'s job unless your storage engine can do it more cheaply itself, in which
+case honour $query here and override get() too.
+
+=head2 write($posts)
+
+Commit an arrayref of posts to storage.  Called by add() once the posts have
+been filtered and validated; don't validate again here.
+
+=head2 tags() = ARRAYREF $tags
+
+Every tag known to the datastore, for building tag pickers.
+
+=cut
+
 #It is required that subclasses implement this
 sub lang  ($self)                { ... }
 sub help  ($self)                { ... }
@@ -145,6 +182,17 @@ sub _filter_param ( $query, $param, @filtered ) {
     return @filtered;
 }
 
+=head2 filter($query, @posts) = @filtered
+
+Apply a get() request's filters to a list of posts: tags, exclude_tags, acls,
+visibility, id, title, form, search terms and author.
+
+The ACL check is the load bearing one -- a post is only visible if the caller
+holds one of its acls, or the post is public or unlisted.  Callers holding the
+'admin' acl skip that filter entirely.
+
+=cut
+
 sub filter ( $self, $query, @filtered ) {
     $query->{acls}         //= [];
     $query->{tags}         //= [];
@@ -205,6 +253,13 @@ sub filter ( $self, $query, @filtered ) {
     return @filtered;
 }
 
+=head2 paginate($query, @posts) = @page
+
+The slice of @posts named by the request's page and limit.  Both have to be
+present to page at all; limit defaults to 25 when computing the offset.
+
+=cut
+
 sub paginate ( $self, $query, @filtered ) {
     my $offset = int( $query->{limit} // 25 );
     $offset   = @filtered < $offset ? @filtered : $offset;
@@ -257,120 +312,224 @@ If any post already exists with the same id, a new post with a version higher th
 
 Passes an array of new posts to add to the data store module's write() function.
 
-These will have their parameters filtered to those present in the %schema hash.
+These will have their parameters filtered to those described by the post type's
+schema (see schema_for()), and then validated against it.  If the post doesn't
+hold up, this dies with an ARRAYREF of validation error strings -- a ref rather
+than a string so that Carp::Always doesn't staple a stack trace onto something
+we intend to show the user.
 
 You probably won't want to override this.
 
 =cut
 
-my $not_ref = sub {
-    return !Ref::Util::is_ref(shift);
-};
-
-my $valid_cb = sub {
-    my $subname = shift;
-    my ($modname) = $subname =~ m/^([\w|:]+)::\w+$/;
-
-    # Modules always return 0 if they succeed!
-    eval { require $modname; } and do {
-        WARN("Post uses a callback whos module ($modname) cannot be found!");
-        return 0;
-    };
-
-    no strict 'refs';
-    my $ref = eval '\&' . $subname;
-    use strict;
-    return Ref::Util::is_coderef($ref);
-};
-
-my $hashref_or_string = sub {
-    my $subj = shift;
-    return Ref::Util::is_hashref($subj) || $not_ref->($subj);
-};
-
-my $arrayref_or_string = sub {
-    my $subj = shift;
-    return Ref::Util::is_arrayref($subj) || $not_ref->($subj);
-};
-
-# TODO more strict validation of strings?
-our %schema = (
-    ## Parameters which must be in every single post
-    'title'      => $not_ref,
-    'callback'   => $valid_cb,
-    'tags'       => \&Ref::Util::is_arrayref,
-    'version'    => $not_ref,
-    'visibility' => $not_ref,
-    'aliases'    => \&Ref::Util::is_arrayref,
-
-    # title links here
-    'href' => $not_ref,
-
-    # Link to post locally
-    'local_href' => $not_ref,
-
-    # Post body
-    'data' => $arrayref_or_string,
-
-    # How do I edit this post?
-    'form' => $not_ref,
-
-    # Post is restricted to visibility to these ACLs if not public/unlisted
-    'acls' => \&Ref::Util::is_arrayref,
-    'id'   => $not_ref,
-
-    # Author of the post
-    'user'    => $not_ref,
-    'created' => $not_ref,
-
-    # Specific to various posts below.
-
-    ## Series specific parameters
-    'child_form' => $not_ref,
-    'aclname'    => $not_ref,
-    'tiled'      => $not_ref,
-
-    ## User specific parameters
-    'user_acls'      => \&Ref::Util::is_arrayref,
-    'username'       => $not_ref,
-    'display_name'   => $not_ref,
-    'contact_email'  => $not_ref,
-    'wallpaper_file' => $hashref_or_string,
-    'wallpaper'      => $not_ref,
-
-    ## user avatar, but does double duty in content posts as preview images on videos, etc
-    'preview_file' => $hashref_or_string,
-    'preview'      => $not_ref,
-
-    ## Content specific parameters
-    'audio_href'  => $not_ref,
-    'video_href'  => $not_ref,
-    'file'        => $hashref_or_string,
-    'attachments' => \&Ref::Util::is_arrayref,
-    'header'      => $not_ref,
-    'footer'      => $not_ref,
-
-    ## Entity details, which are used for constructing invoices
-    'payment_details' => $not_ref,
-    'payment_method'  => $not_ref,
-
-    ## Invoice specific
-    'payee'    => $not_ref,
-    'payor'    => $not_ref,
-    'due_days' => $not_ref,
+# The shape of a post, as an OpenAPIv3 object schema.
+#
+# This covers the fields every post has regardless of which form produced it.
+# Anything a *particular* post type ingests lives in that type's JSON sidecar
+# next to its template in the forms directory -- see _schema_for().
+our %post_schema = (
+    type       => 'object',
+    properties => {
+
+        ## Parameters which must be in every single post
+        title      => { type => 'string' },
+        callback   => { type => 'callback' },
+        tags       => { type => 'array',   items   => { type => 'string' } },
+        version    => { type => 'integer', minimum => 0 },
+        visibility => { type => 'string',  enum    => [qw{public unlisted private}] },
+        aliases    => { type => 'array',   items   => { type => 'string' } },
+
+        # title links here
+        href => { type => 'string' },
+
+        # Link to post locally
+        local_href => { type => 'string' },
+
+        # Post body.  Multi-page types (presentations, invoices) send an array.
+        data => {
+            oneOf => [
+                { type => 'string' },
+                { type => 'array', items => { type => 'string' } },
+            ],
+        },
+
+        # How do I edit this post?
+        form => { type => 'string' },
+
+        # Post is restricted to visibility to these ACLs if not public/unlisted
+        acls => { type => 'array', items => { type => 'string' } },
+        id   => { type => 'string' },
+
+        # Author of the post
+        user    => { type => 'string' },
+        created => { type => 'integer' },
+
+        # Posts are always GET, but it's stored, so it has to be describable.
+        method => { type => 'string' },
+    },
+);
+
+# Uploads arrive as an HTTP::Body hashref on the way in, and as the href string
+# they were turned into on the way back out of the datastore.  Sidecars say
+# 'upload' and mean this.
+our %upload_schema = (
+    oneOf => [
+        { type => 'string' },
+        { type => 'object' },
+    ],
 );
 
+=head2 schema_for($form)
+
+Return the OpenAPIv3 schema describing what the named post type ingests: the
+base post schema above, with the type's JSON sidecar merged over the top.
+
+Sidecars live beside their templates (blog.tx has blog.json) and are written
+either by hand or by the Post Type Wizard.  A post with no form, or a form with
+no sidecar, just gets the base schema.
+
+Cached, but keyed on the mtimes of the component dirs rather than memoized
+outright: adding or editing a sidecar bumps one of them, so every forked worker
+picks the change up on its very next add() with no restart needed.
+
+=cut
+
+sub schema_for ( $form = '' ) {
+    state %cache;
+
+    # Both dirs, since either one of them gaining a sidecar changes the answer.
+    my $generation = join( ':', map { ( stat($_) )[9] // 0 } Trog::Themes::template_dirs( 'text/html', 1 ) );
+
+    # 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 //= '';
+    return $cache{$generation}{$type} if exists $cache{$generation}{$type};
+
+    my %merged = ( %post_schema, properties => { %{ $post_schema{properties} } } );
+
+    # Themed like the templates themselves: a theme that overrides blog.tx can
+    # ship its own blog.json alongside it, and one that doesn't still gets the
+    # stock schema rather than nothing at all.
+    my $path    = $type ? Trog::Themes::themed_file_in_dir( 'forms', "$type.json", 'text/html', 1 ) : undef;
+    my $sidecar = $path ? _read_sidecar($path)                                                      : undef;
+    if ($sidecar) {
+
+        # The base schema is merged *last*, so a sidecar can add fields but can
+        # never redefine one of ours.  That matters: a sidecar retyping
+        # 'callback' as a plain string would defeat the check that the sub it
+        # names actually exists, which is a privilege problem rather than a
+        # cosmetic one.
+        %{ $merged{properties} } = ( %{ $sidecar->{properties} // {} }, %{ $merged{properties} } );
+
+        # A sidecar may insist on its own fields, but it can't relax anything
+        # the base schema already demands.
+        my @required = List::Util::uniq( @{ $post_schema{required} // [] }, @{ $sidecar->{required} // [] } );
+
+        # An empty required list isn't legal OpenAPI, so don't emit one.
+        $merged{required} = \@required if @required;
+    }
+
+    $cache{$generation}{$type} = \%merged;
+    return $cache{$generation}{$type};
+}
+
+sub _read_sidecar ($path) {
+    return undef unless -f $path;
+
+    local $@;
+    my $spec = eval { JSON::MaybeXS::decode_json( File::Slurper::read_text($path) ) };
+    if ( !$spec ) {
+        WARN("Could not parse post type sidecar '$path': $@");
+        return undef;
+    }
+    return undef unless Ref::Util::is_hashref($spec);
+
+    _expand_uploads($spec);
+    return $spec;
+}
+
+# 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) {
+    return unless Ref::Util::is_hashref($node);
+
+    if ( ( $node->{type} // '' ) eq 'upload' ) {
+        delete $node->{type};
+        %$node = ( %$node, %upload_schema );
+        return;
+    }
+
+    _expand_uploads($_) foreach values( %{ $node->{properties} // {} } );
+    _expand_uploads( $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} };
+    }
+    return;
+}
+
+=head2 validate($post)
+
+Filter a post down to the fields its type actually describes, then run what's
+left through the schema.
+
+Returns the list of validation errors, which is empty when the post is good.
+Note that filtering happens first and silently: the query hash handed to us by
+the router is full of things which aren't post fields at all, and never was
+meant to round-trip.
+
+=cut
+
+sub validate ($post) {
+    state $validator;
+    $validator //= JSON::Validator::Schema::Troglodyne->new();
+
+    my $schema = schema_for( $post->{form} );
+
+    foreach my $key ( keys(%$post) ) {
+
+        # Drop everything the schema doesn't describe.
+        my $property = $schema->{properties}{$key};
+        if ( !$property ) {
+            delete $post->{$key};
+            next;
+        }
+
+        # An untouched form input submits the empty string, which is HTML for
+        # "I wasn't filled in" rather than a number, a boolean or a file.  We
+        # leave it alone for actual string fields, which is what got stored
+        # before any of this was typed.
+        delete $post->{$key}
+          if defined $post->{$key}
+          && !ref $post->{$key}
+          && $post->{$key} eq ''
+          && ( $property->{type} // '' ) ne 'string';
+    }
+
+    # OpenAPIv3 coerces as it goes, so "4" lands in the datastore as 4 and
+    # checkbox values land as real booleans.
+    return $validator->validate( $post, $schema );
+}
+
 sub add ( $self, @posts ) {
     my @to_write;
 
     foreach my $post (@posts) {
 
-        # Filter all the irrelevant data
-        foreach my $key ( keys(%$post) ) {
+        # Filter to what this post type actually describes, then validate it.
+        my @errors = validate($post);
 
-            # We need to have the key in the schema, and it validate.
-            delete $post->{$key} unless List::Util::any { ( $_ eq $key ) && ( $schema{$key}->( $post->{$key} ) ) } keys(%schema);
-        }
+        # An arrayref rather than a string on purpose.  These errors get shown
+        # to whoever submitted the post, and Carp::Always decorates a string
+        # die with a stack trace they have no use for.
+        die [ map { "$_" } @errors ] if @errors;
 
         $post->{id}      //= Trog::Utils::uuid();
         $post->{aliases} //= [];

lib/Trog/Renderer/Base.pm

@@ -24,6 +24,30 @@ Sets up the methods which must be present for all templates, e.g. render_it for
 
 our %renderers;
 
+=head2 render(%options)
+
+Render a template and build the PSGI response around it.
+
+Recognized options:
+
+    template    => the template's filename, relative to the template dir.  Required.
+    contenttype => what we're rendering, e.g. 'text/html'.  Picks the template dir.
+    component   => render a component rather than a whole page.  Returns just the
+                   body string, with no headers and no compression.
+    data        => the variables handed to the template.
+    code        => HTTP status for the response.
+    headers     => extra headers, merged over the computed ones.
+    deflate     => gzip the body and set Content-Encoding.
+    post_processor => CODEREF run over the body before headers are computed, for
+                   things like minifiers.
+    child_processor / child_renderer => override how post bodies are rendered by
+                   the render_it() template function.  Built for you if omitted.
+
+Dies unless the template exists.  Returns the body string for components, and a
+PSGI arrayref of [ code, headers, body ] otherwise.
+
+=cut
+
 sub render (%options) {
     die "Templated renders require a template to be passed" unless $options{template};
 
@@ -31,8 +55,14 @@ sub render (%options) {
     my $t            = "$template_dir/$options{template}";
     die "Templated renders require an existing template to be passed, got $template_dir/$options{template}" unless -f $t || -s $t;
 
+    # Xslate resolves includes against every dir in path, first match winning,
+    # so handing it both lets a theme override individual templates without
+    # having to fork the ones next to them.  With no theme configured this is
+    # just the stock dir, exactly as it was.
+    my @template_dirs = Trog::Themes::template_dirs( $options{contenttype}, $options{component} );
+
     #TODO make this work with posts all the time
-    $options{child_processor} //= Text::Xslate->new( path => $template_dir );
+    $options{child_processor} //= Text::Xslate->new( path => \@template_dirs );
     my $child_processor = $options{child_processor};
     $options{child_renderer} //= sub {
         my ( $template_string, $options ) = @_;
@@ -42,15 +72,18 @@ sub render (%options) {
         return $out ? $out : $template_string;
     };
 
-    $renderers{$template_dir} //= Text::Xslate->new(
-        path     => $template_dir,
+    # Keyed on the whole search path, not just the winning dir: two different
+    # paths that happen to start with the same dir are not the same renderer.
+    my $renderer_key = join( ':', @template_dirs );
+    $renderers{$renderer_key} //= Text::Xslate->new(
+        path     => \@template_dirs,
         function => {
             render_it => $options{child_renderer},
         },
     );
 
     my $code = $options{code};
-    my $body = encode_utf8( $renderers{$template_dir}->render( $options{template}, $options{data} ) );
+    my $body = encode_utf8( $renderers{$renderer_key}->render( $options{template}, $options{data} ) );
 
     # Users can supply a post_processor to futz with the output (such as with minifiers) if they wish.
     $body = $options{post_processor}->($body) if $options{post_processor} && ref $options{post_processor} eq 'CODE';
@@ -70,6 +103,17 @@ sub render (%options) {
     return [ $code, [%headers], [$dfh] ];
 }
 
+=head2 headers($options, $body) = %headers
+
+The response headers for a rendered body: content type and length, caching,
+Server-Timing, and the security headers (CSP, X-Frame-Options, HSTS when we're
+on https, nosniff).  Anything in $options->{headers} is merged over the top.
+
+ETags are only set for logged in users, as everyone else is served out of the
+static render cache.
+
+=cut
+
 sub headers ( $options, $body ) {
     my $query   = $options->{data};
     my $uh      = ref $options->{headers} eq 'HASH'      ? $options->{headers}        : {};

lib/Trog/Routes/HTML.pm

@@ -12,6 +12,7 @@ use File::Touch();
 use File::Basename qw{basename};
 use List::Util();
 use List::MoreUtils();
+use Ref::Util();
 use Capture::Tiny qw{capture};
 use HTML::SocialMeta;
 
@@ -19,6 +20,7 @@ use Clone qw{clone};
 use Encode qw{encode_utf8};
 use Digest::MD5 qw{md5_hex};
 use Digest::SHA qw{sha256_hex};
+use JSON::MaybeXS();
 use IO::Compress::Gzip;
 use Path::Tiny();
 use File::Basename qw{dirname};
@@ -169,6 +171,13 @@ our %routes = (
         noindex  => 1,
         nocache  => 1,
     },
+    '/admin/wyzzerdd/save' => {
+        method   => 'POST',
+        auth     => 1,
+        callback => \&Trog::Routes::HTML::post_wizard_save,
+        noindex  => 1,
+        nocache  => 1,
+    },
 
     #TODO transform into posts?
     '/sitemap',
@@ -878,7 +887,15 @@ sub post_save ($qq) {
     state $data;
     $data //= Trog::Data->new(Trog::Config::get());
 
-    $data->add($query) and die "Could not add post";
+    # A post that doesn't match its type's schema is the user's mistake, not a
+    # server error, so hand the validation errors back rather than dying.
+    local $@;
+    eval { $data->add($query); 1 } or do {
+        my @errors = Ref::Util::is_arrayref($@) ? @{$@} : ($@);
+        my $why    = "Post failed validation:\n" . join( "\n", @errors );
+        WARN("Rejected post from $qq->{user}: $why");
+        return $qq->{tpsgi}->badrequest( $qq, $why );
+    };
 
     # Instruct tpsgi to invalidate the cached render.
     $qq->{tpsgi}->add_post_close_callback(sub {
@@ -913,13 +930,12 @@ sub profile ($query) {
 
     my $user_obj = List::Util::first { ( $_->{user} || '' ) eq $query->{username} } @userposts;
 
-    if ( $query->{username} ne $user_obj->{user} || $query->{password} || $query->{contact_email} ne $user_obj->{contact_email} || $query->{display_name} ne $user_obj->{display_name} ) {
-        my $for_user = Trog::Auth::acls4user( $query->{username} );
-
-        #TODO support non-admin users
-        my @acls = @$for_user ? @$for_user : qw{admin};
-        Trog::Auth::useradd( $query->{username}, $query->{display_name}, $query->{password}, \@acls, $query->{contact_email} );
-    }
+    my $username = $query->{username};
+    my $password = $query->{password};
+    my $changed  = $username ne ( $user_obj->{user} // '' )
+      || $password
+      || ( $query->{contact_email} // '' ) ne ( $user_obj->{contact_email} // '' )
+      || ( $query->{display_name}  // '' ) ne ( $user_obj->{display_name}  // '' );
 
     #Make sure it is "self-authored", redact pw
     $query->{user} = delete $query->{username};
@@ -934,6 +950,25 @@ sub profile ($query) {
         $query->{display_name} ? ( local_href => "/users/$query->{display_name}" ) : ( local_href => $user_obj->{local_href} ),
     );
 
+    # Validate before touching the auth database, not after.  useradd() does an
+    # INSERT OR REPLACE on the user row, which cascades to the session table and
+    # logs the user straight out -- doing that and *then* rejecting the post
+    # leaves the credentials disagreeing with the profile post they came from.
+    my @errors = Trog::DataModule::validate( clone( \%merged ) );
+    if (@errors) {
+        my $why = "Post failed validation:\n" . join( "\n", @errors );
+        WARN("Rejected profile update from $query->{user}: $why");
+        return $query->{tpsgi}->badrequest( $query, $why );
+    }
+
+    if ($changed) {
+        my $for_user = Trog::Auth::acls4user($username);
+
+        #TODO support non-admin users
+        my @acls = @$for_user ? @$for_user : qw{admin};
+        Trog::Auth::useradd( $username, $merged{display_name}, $password, \@acls, $merged{contact_email} );
+    }
+
     return post_save( \%merged );
 }
 
@@ -1220,8 +1255,8 @@ sub posts ( $query, $direct = 0 ) {
     return $header if ref $footer eq 'ARRAY';
 
     # List the available headers/footers
-    my $headers = Trog::Themes::templates_in_dir( "headers", 'text/html', 1 );
-    my $footers = Trog::Themes::templates_in_dir( "footers", 'text/html', 1 );
+    my $headers = Trog::Themes::themed_templates_in_dir( "headers", 'text/html', 1 );
+    my $footers = Trog::Themes::themed_templates_in_dir( "footers", 'text/html', 1 );
 
     #XXX used to be post.css, but probably not good anymore?
     my $styles = [];
@@ -1266,7 +1301,7 @@ sub posts ( $query, $direct = 0 ) {
         $_
     } _post_helper( {}, ['series'], $query->{user_acls} );
 
-    my $forms = Trog::Themes::templates_in_dir( "forms", 'text/html', 1 );
+    my $forms = Trog::Themes::themed_templates_in_dir( "forms", 'text/html', 1 );
 
     my $edittype = $query->{primary_post} ? $query->{primary_post}->{child_form}          : $query->{form};
     my $tiled    = $query->{primary_post} ? !$is_admin && $query->{primary_post}->{tiled} : 0;
@@ -1658,6 +1693,16 @@ sub manual ($query) {
     );
 }
 
+=head2 processed
+
+Implements /processed.
+
+The "we got it, go check your email" page, shown after a request that finishes
+out of band -- password and TOTP resets, chiefly.  Deliberately says nothing
+about whether the account existed.
+
+=cut
+
 sub processed ($query) {
     return Trog::Routes::HTML::index(
         {
@@ -1669,6 +1714,16 @@ sub processed ($query) {
     );
 }
 
+=head2 metrics
+
+Implements /metrics.  Admin only.
+
+Renders the request metrics dashboard.  The page pulls its actual numbers from
+/api/requests_per over XHR and draws them with chart.js, so there's nothing to
+compute here.
+
+=cut
+
 sub metrics ($query) {
     return $query->{tpsgi}->see_also('/login')                    unless $query->{user};
     return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
@@ -1689,6 +1744,20 @@ sub metrics ($query) {
     );
 }
 
+=head2 sessions
+
+Implements /sessions.  Admin only.
+
+The session audit log: logins, logouts and failures, most recent first.
+Filterable by username and event type via the filter_user and filter_event
+parameters, and capped by limit (100 by default).
+
+Timestamps are formatted here rather than in the template, and session ids are
+truncated to their first 8 characters -- there's no reason to put a live
+session id on a page.
+
+=cut
+
 sub sessions ($query) {
     return $query->{tpsgi}->see_also('/login')  unless $query->{user};
     return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
@@ -1726,35 +1795,377 @@ sub sessions ($query) {
     );
 }
 
+# The canned includes the wizard is willing to splice into a generated form.
+# Deliberately a whitelist keyed on the checkbox name -- the include name ends
+# up interpolated straight into a template file, so it can never come from the
+# submitted data.
+our %wizard_includes = (
+    inc_preview     => 'preview.tx',
+    inc_visibility  => 'visibility.tx',
+    inc_acls        => 'acls.tx',
+    inc_tags        => 'tags.tx',
+    inc_aliases     => 'aliases.tx',
+    inc_attachments => 'attachments.tx',
+);
+
+# Emitted in this order, so generated forms read like the hand-written ones.
+our @wizard_include_order = qw{inc_preview inc_visibility inc_acls inc_tags inc_aliases inc_attachments};
+
+# Every checkbox on the wizard, and which of them start out ticked.
+our @wizard_checkboxes         = ( qw{wrapper inc_post_title inc_post_tags inc_title_input}, @wizard_include_order, 'overwrite' );
+our %wizard_checked_by_default = map { $_ => 1 } qw{wrapper inc_post_title inc_post_tags inc_title_input inc_preview inc_visibility inc_acls inc_tags inc_aliases};
+
+# Which HTML input the wizard emits, and what that field is in the sidecar's
+# OpenAPIv3 schema.  No 'file': _process() in Trog::DataModule only knows how to
+# turn the four hardcoded upload fields into hrefs, so a custom file field would
+# store an HTTP::Body::OctetStream that nothing ever picks up.  Point folks at
+# the attachment uploader instead.
+our %wizard_field_types = (
+    text     => { type => 'string' },
+    url      => { type => 'string' },
+    date     => { type => 'string' },
+    textarea => { type => 'string' },
+    number   => { type => 'integer' },
+    checkbox => { type => 'boolean' },
+);
+
+# Field names which aren't in %schema but would still collide with something.
+our @wizard_reserved = qw{app to form data_is_array addpost extra_tags is_image is_video is_audio is_profile content_type version};
+
+=head2 post_wizard
+
+Implements /admin/wyzzerdd.  Admin only.
+
+The post type wizard: lists the post types which currently exist and offers a
+form for building a new one.  See post_wizard_save() for what happens when that
+form comes back.
+
+Re-rendered by post_wizard_save() on both success and failure, so it keeps the
+submitted values and checkbox states rather than making the admin retype
+everything after a rejected submission.
+
+=cut
+
 sub post_wizard ($query) {
     return $query->{tpsgi}->see_also('/login')  unless $query->{user};
     return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
+    $query->{failure} //= -1;
+
     # Get the existing post types
-    my $forms = Trog::Themes::templates_in_dir( "forms", 'text/html', 1 );
+    my $forms = Trog::Themes::themed_templates_in_dir( "forms", 'text/html', 1 );
+
+    # Sticky checkboxes.  Nothing is submitted on a fresh GET, so fall back to
+    # the defaults rather than rendering everything unticked.
+    my %checked = map { $_ => ( $query->{wizard_submitted} ? $query->{$_} : $wizard_checked_by_default{$_} ) ? 'checked' : '' } @wizard_checkboxes;
 
     return Trog::Routes::HTML::index(
         {
-            title        => 'tCMS Post Wizard',
-            theme_dir    => Trog::Themes::td(),
-            template     => 'post_wizard.tx',
-            is_admin     => 1,
-            forms        => $forms,
+            # Sticky form values first, so a failed submission doesn't lose the
+            # admin's work -- but everything the template actually depends on is
+            # set *after* this, as the whole of %$query is attacker controlled.
             %$query,
+            title             => 'tCMS Post Wizard',
+            theme_dir         => Trog::Themes::td(),
+            template          => 'post_wizard.tx',
+            is_admin          => 1,
+            forms             => $forms,
+            forms_dir         => Trog::Themes::forms_dir(),
+            checked           => \%checked,
+            name              => _wizard_scalar( $query->{name} ),
+            title_placeholder => _wizard_scalar( $query->{title_placeholder} ),
+            body_form         => _wizard_scalar( $query->{body_form} ),
+            display           => _wizard_scalar( $query->{display} ),
+            failure           => $query->{failure},
+            message           => $query->{message} // '',
+            to                => $query->{to}      // '',
         },
         undef,
         ['post.css'],
     );
 }
 
+=head2 post_wizard_save
+
+Implements POST /admin/wyzzerdd/save.
+
+Writes a new post type template into whichever forms directory is currently in
+use, along with a JSON sidecar naming its custom fields so that
+Trog::DataModule::schema_for will merge it over the base post schema, so the
+type's own fields survive validation at save time.
+
+=cut
+
+sub post_wizard_save ($query) {
+    return $query->{tpsgi}->see_also('/login')  unless $query->{user};
+    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+
+    # Anchored capture rather than a substitution, so anything containing a '/'
+    # or a '..' simply fails to match instead of being silently scrubbed into
+    # something that still escapes the directory.
+    my ($name) = _wizard_scalar( $query->{name} ) =~ m/^([A-Za-z0-9_-]+)$/;
+    return _wizard_fail( $query, "Post type names may only contain letters, numbers, '-' and '_'." ) unless $name;
+
+    # Whichever forms dir is in use: the theme's if it has one, the stock one
+    # otherwise.  Never mkdir it -- silently conjuring a forms/ dir inside a
+    # theme is not something an admin asked for by pressing this button.
+    my $dir = Trog::Themes::forms_dir();
+    return _wizard_fail( $query, "Forms directory '$dir' does not exist, or is not writable." ) unless -d $dir && -w $dir;
+
+    my $tx_file   = "$dir/$name.tx";
+    my $json_file = "$dir/$name.json";
+
+    my $overwriting = -e $tx_file;
+    return _wizard_fail( $query, "Post type '$name.tx' already exists.  Tick 'Overwrite' if you meant to replace it." )
+      if $overwriting && !$query->{overwrite};
+
+    my $fields    = _wizard_fields($query);
+    my @includes  = grep { $query->{$_} } @wizard_include_order;
+    my $body_form = _wizard_scalar( $query->{body_form} ) eq 'form_multi.tx' ? 'form_multi.tx' : 'form_common.tx';
+
+    my $spec = _wizard_sidecar( $name, $fields, \@includes, $body_form );
+
+    local $@;
+    eval {
+        Path::Tiny::path($tx_file)->spew_utf8( _wizard_template( $query, $fields, \@includes, $body_form ) );
+        Path::Tiny::path($json_file)->spew_utf8( JSON::MaybeXS->new( pretty => 1, canonical => 1 )->encode($spec) );
+        1;
+    } or return _wizard_fail( $query, "Failed to write post type '$name': $@" );
+
+    INFO("Post type '$name' written to $tx_file by $query->{user}");
+
+    # Nothing else is needed to publish a new type: themed_templates_in_dir()
+    # re-reads
+    # the directory every call, and Xslate resolves includes lazily, so both the
+    # wizard's own list and the series child_form dropdown pick it up on the
+    # next request without a restart.  Overwriting an *existing* type is another
+    # matter -- that changes how already-rendered anonymous pages should look.
+    if ($overwriting) {
+        $query->{tpsgi}->add_post_close_callback(
+            sub {
+                $query->{tpsgi}->invalidate_renders('html');
+            }
+        );
+    }
+
+    return post_wizard(
+        {
+            %$query,
+            wizard_submitted => 1,
+            failure          => 0,
+            message          => "Created post type '$name.tx'.",
+            to               => '/admin/wyzzerdd',
+        }
+    );
+}
+
+# Repeated params arrive as arrayrefs; anywhere we want one string, insist on one string.
+sub _wizard_scalar ( $value = '' ) {
+    return '' if !defined $value || ref $value;
+    return $value;
+}
+
+sub _wizard_fail ( $query, $message ) {
+    WARN($message);
+    return post_wizard(
+        {
+            %$query,
+            wizard_submitted => 1,
+            failure          => 1,
+            message          => $message,
+        }
+    );
+}
+
+=head2 _kolon_safe
+
+Make a submitted string safe to splice into a generated Kolon template.
+Newlines have to go, as a ':' at the start of a line is a Kolon directive, and
+the angle brackets have to go so that '<:' can never be reassembled.
+
+=cut
+
+sub _kolon_safe ( $string = '' ) {
+    $string = _wizard_scalar($string);
+    $string =~ s/[\r\n]+/ /g;
+    $string =~ s/&/&amp;/g;
+    $string =~ s/</&lt;/g;
+    $string =~ s/>/&gt;/g;
+    $string =~ s/"/&quot;/g;
+    return $string;
+}
+
+=head2 _wizard_fields
+
+Zip the parallel param_* arrays submitted by the wizard back into a list of
+field definitions.  Every row always submits exactly one of each param, so the
+arrays stay aligned even when a row is left blank.
+
+=cut
+
+sub _wizard_fields ($query) {
+    my $names  = Trog::Utils::coerce_array( $query->{param_name} );
+    my $types  = Trog::Utils::coerce_array( $query->{param_type} );
+    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 ( @fields, %seen );
+    foreach my $index ( 0 .. $#$names ) {
+        my ($fname) = lc( _wizard_scalar( $names->[$index] ) ) =~ m/^([a-z][a-z0-9_]{0,31})$/;
+
+        # Blank and bogus rows just get dropped.
+        next unless $fname;
+        next if $seen{$fname}++;
+
+        # Never let a custom field shadow a core post attribute.
+        next if exists $Trog::DataModule::post_schema{properties}{$fname};
+        next if grep { $fname eq $_ } @wizard_reserved;
+
+        my $type = _wizard_scalar( $types->[$index] );
+        $type = 'text' unless $wizard_field_types{$type};
+
+        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,
+            }
+        );
+    }
+    return \@fields;
+}
+
+=head2 _wizard_sidecar
+
+Turn the wizard's field list into the post type's JSON sidecar: an OpenAPIv3
+object schema describing what this type ingests, with the wizard's own UI
+metadata hung off x- extension keys so there's only one file to keep in sync.
+
+Trog::DataModule::schema_for() merges this over the base post schema.
+
+=cut
+
+sub _wizard_sidecar ( $name, $fields, $includes, $body_form ) {
+    my %properties;
+    my @required;
+
+    foreach my $field (@$fields) {
+        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};
+
+        $properties{ $field->{name} } = $property;
+        push( @required, $field->{name} ) if $field->{required};
+    }
+
+    my %spec = (
+        'x-tcms-post-type' => {
+            name      => $name,
+            generated => JSON::MaybeXS::true(),
+            generator => 'Trog::Routes::HTML::post_wizard_save',
+            body_form => $body_form,
+            includes  => [ map { $wizard_includes{$_} } @$includes ],
+        },
+        type       => 'object',
+        properties => \%properties,
+    );
+    $spec{required} = \@required if @required;
+
+    return \%spec;
+}
+
+sub _wizard_field_html ($field) {
+    my ( $n, $t, $l, $p ) = @$field{qw{name type label placeholder}};
+    my $required = $field->{required} ? 'required ' : '';
+
+    return qq|            $l<br /><textarea ${required}class="cooltext" name="$n" placeholder="$p"><: \$post.$n :></textarea>\n|
+      if $t eq 'textarea';
+
+    return qq|            <label for="<: \$post.id :>-$n">$l<input id="<: \$post.id :>-$n" class="coolcb" type="checkbox" name="$n" value="1" <: if ( \$post.$n ) { "checked" } :> /></label><br />\n|
+      if $t eq 'checkbox';
+
+    return qq|            $l<br /><input ${required}class="cooltext" type="$t" name="$n" placeholder="$p" value="<: \$post.$n :>" />\n|;
+}
+
+=head2 _wizard_template
+
+Assemble the actual .tx file, following the shape of the hand-written forms:
+a display half guarded by !$post.addpost, and an edit half guarded by $can_edit.
+
+=cut
+
+sub _wizard_template ( $query, $fields, $includes, $body_form ) {
+    my $placeholder = _kolon_safe( $query->{title_placeholder} ) || 'Iowa Man Destroys Moon';
+
+    # NOT escaped, on purpose.  Letting an admin write template code is the
+    # entire point of the wizard, and it is no more privileged than the data
+    # field of any post, which already gets run through render_it().  Both
+    # sides of this route are behind the admin ACL.
+    my $display = _wizard_scalar( $query->{display} );
+
+    my $out = "<!-- Generated by the tCMS Post Type Wizard.  Regenerating this type will overwrite any hand edits. -->\n";
+    $out .= qq|<div class="post <: \$style :>">\n| if $query->{wrapper};
+    $out .= qq|    : if ( !\$post.addpost ) {\n|;
+    $out .= qq|        : include "post_title.tx";\n| if $query->{inc_post_title};
+    $out .= qq|        : include "post_tags.tx";\n|  if $query->{inc_post_tags};
+    $out .= "$display\n"                             if $display;
+    $out .= qq|    : }\n\n|;
+    $out .= qq|    : if ( \$can_edit ) {\n|;
+    $out .= qq|        <div class="postedit">\n|;
+    $out .= qq|        : include "edit_head.tx";\n|;
+    $out .= qq|        <form class="Submissions" action="/post/save" method="POST" enctype="multipart/form-data">\n|;
+    $out .= qq|            Title *<br /><input required class="cooltext" type="text" name="title" placeholder="$placeholder" value="<: \$post.title :>" />\n|
+      if $query->{inc_title_input};
+    $out .= _wizard_field_html($_) foreach @$fields;
+
+    foreach my $include (@$includes) {
+        $out .= qq|            : include "$wizard_includes{$include}";\n|;
+    }
+
+    # Always last, and never optional: this is what carries the post body, the
+    # app/to/id/form hiddens and the submit button.
+    $out .= qq|            : include "$body_form";\n|;
+    $out .= qq|        </form>\n|;
+    $out .= qq|        : include "edit_foot.tx";\n|;
+    $out .= qq|        </div>\n|;
+    $out .= qq|    : }\n|;
+    $out .= qq|</div>\n| if $query->{wrapper};
+    return $out;
+}
+
 
 # basically a file rewrite rule for themes
+=head2 icon
+
+Implements the /img/icon/* routes.
+
+Serves a themed icon, falling back to the stock one.  A rewrite rule with extra
+steps, essentially, so that themes can replace individual icons.
+
+=cut
+
 sub icon ($query) {
     my $path = $query->{route};
     my $tpath = Trog::Themes::themed("img/icon/$path");
     return $query->{tpsgi}->serve( $path, $tpath, $query->{start}, $query->{streaming}, $query->{ranges}, $query->{last_fetched}, $query->{deflate}  );
 }
 
+=head2 totp_qr
+
+Implements the /totp/* routes.
+
+Serves the QR code generated when a user enables TOTP.  These live outside
+www/, so they go out through serve() rather than the static file handler --
+handing someone else's enrolment QR out to the world would be handing them the
+shared secret.
+
+=cut
+
 sub totp_qr ($query) {
     my $fname = basename($query->{route});
     # For authenticated content, we have to now do a serve().
@@ -1769,6 +2180,16 @@ sub totp_qr ($query) {
     );
 }
 
+=head2 rss_style
+
+Implements /styles/rss-style.xsl.
+
+The XSL stylesheet which makes the RSS feed legible in a browser.  The header
+and footer are rendered here and passed in as strings because the output is
+XSL rather than HTML, so an include directive isn't available.
+
+=cut
+
 sub rss_style ($query) {
     $query->{port}       = ":$query->{port}" if $query->{port};
     $query->{title}      = qq{<xsl:value-of select="rss/channel/title"/>};
@@ -1796,6 +2217,19 @@ sub _build_themed_scripts ($scripts) {
     return \@scripts;
 }
 
+=head2 finish_render($template, $vars, %headers)
+
+Render a full page, as opposed to a component.
+
+Fills in the defaults every page needs (lang, title, status code, content type,
+cache control), resolves stylesheet and script names through the theme, makes
+their paths absolute, renders the header and footer, and hands the lot to
+Trog::Renderer.
+
+Just about everything in this module ends up here; index() is the usual way in.
+
+=cut
+
 sub finish_render ( $template, $vars, %headers ) {
 
     #XXX default vars that need to be pulled from config

lib/Trog/Themes.pm

@@ -19,6 +19,17 @@ Utility functions for getting themed paths.
 
 our $template_dir = 'www/templates';
 
+=head2 routes() = %routes
+
+The active theme's own routing table, from its routes.pm.
+
+Themes can add routes of their own by shipping a routes.pm which populates
+%Theme::routes.  Returns an empty list when there's no theme, or when the theme
+hasn't got one.  Dies if there is a routes.pm and it won't load, as silently
+serving a site with half its routes missing is worse than not starting.
+
+=cut
+
 sub routes {
     my $rdir = get_dir();
     return () unless -f "$rdir/routes.pm";
@@ -31,6 +42,18 @@ sub routes {
     return %Theme::routes;
 }
 
+=head2 get_dir() = STRING $dir
+
+The active theme's directory, relative to the tCMS root, e.g.
+C<www/themes/mytheme>.  Empty string when no theme is configured, or when the
+configured one doesn't exist on disk -- so it's safe to interpolate either way,
+and truthiness is the test for "is there a theme".
+
+Memoized for the life of the process: changing the theme goes through
+/config/save, which signals the workers to restart.
+
+=cut
+
 sub get_dir {
     state $tdir = '';
     return $tdir if $tdir;
@@ -43,18 +66,60 @@ sub get_dir {
     return $tdir;
 };
 
+=head2 td() = STRING $dir
+
+get_dir() as a rooted URL path rather than a filesystem one, for templates to
+build asset links with.  Empty string when there's no theme.
+
+=cut
+
 sub td {
     my $dir = get_dir();
     return $dir ? "/$dir" : '';
 }
 
-sub template_dir ( $template, $content_type, $is_component = 0, $is_dir = 0 ) {
-    my $ct = $Trog::Vars::byct{$content_type};
-    my ( $mtd, $mtemp ) = ( get_dir() . "/templates/$ct", "$template_dir/$ct" );
+# The theme's template dir and the stock one, in that order of preference.
+# The theme entry is empty when no theme is configured, so callers can just
+# grep for truth rather than repeating the "is there a theme" dance.
+sub _template_dirs ( $content_type, $is_component = 0 ) {
+    my $ct    = $Trog::Vars::byct{$content_type};
+    my $theme = get_dir();
+
+    my ( $themed, $stock ) = ( $theme ? "$theme/templates/$ct" : '', "$template_dir/$ct" );
     if ($is_component) {
-        $mtd   .= "/components";
-        $mtemp .= "/components";
+        $themed .= "/components" if $themed;
+        $stock  .= "/components";
     }
+    return ( $themed, $stock );
+}
+
+=head2 template_dirs($content_type, $is_component)
+
+Every directory which could satisfy a template, most specific first.
+
+Hand this to Text::Xslate as its C<path> and a theme gets to override
+individual templates without having to fork every last one of them.
+
+=cut
+
+sub template_dirs ( $content_type, $is_component = 0 ) {
+    return grep { $_ && -d $_ } _template_dirs( $content_type, $is_component );
+}
+
+=head2 template_dir($template, $content_type, $is_component, $is_dir)
+
+The single directory which owns $template: the theme's if it has its own copy,
+the stock one otherwise.  With $is_dir, $template names a subdirectory (forms,
+headers, footers) rather than a file.
+
+This answers "who owns this one thing", which is what you want when *writing*.
+For reading a whole directory you almost always want themed_templates_in_dir()
+instead, which spans both rather than making you pick.
+
+=cut
+
+sub template_dir ( $template, $content_type, $is_component = 0, $is_dir = 0 ) {
+    my ( $mtd, $mtemp ) = _template_dirs( $content_type, $is_component );
     if ($is_dir) {
         return $mtd && -d "$mtd/$template" ? $mtd : $mtemp;
     }
@@ -67,10 +132,24 @@ sub _dir_for_resource ($resource) {
     return $theme_dir && -f "$theme_dir/$resource" ? $theme_dir : '';
 }
 
+=head2 themed($resource)
+
+Path to a www/-relative resource, preferring the theme's copy.
+
+=cut
+
 sub themed ($resource) {
     return _dir_for_resource("$resource") . "/$resource";
 }
 
+=head2 themed_style($resource) = @hrefs
+
+Stylesheets are the exception to the "one or the other" rule: you get the stock
+sheet *and* the theme's, in that order, so a theme can override a handful of
+rules without restating the whole thing.
+
+=cut
+
 # For style we want to load *both* style files and have the override come later.
 sub themed_style ($resource) {
     my @styles = ("/styles/$resource");
@@ -80,24 +159,127 @@ sub themed_style ($resource) {
     return @styles;
 }
 
+=head2 themed_script($resource)
+
+Path to a script under www/scripts, preferring the theme's copy.
+
+=cut
+
 sub themed_script ($resource) {
     return _dir_for_resource("scripts/$resource") . "/scripts/$resource";
 }
 
+=head2 themed_template($resource)
+
+Path to a template under www/templates, preferring the theme's copy.
+
+=cut
+
 sub themed_template ($resource) {
     return _dir_for_resource("templates/$resource") . "/templates/$resource";
 }
 
+=head2 dir_for($path, $content_type, $is_component)
+
+The single directory which owns a given component subdir: the theme's if it has
+one, the stock one otherwise.  This is the right answer for I<writing> -- see
+forms_dir() and the post type wizard.  For reading, you almost certainly want
+themed_templates_in_dir() instead, which spans both.
+
+=cut
+
+sub dir_for ( $path, $ct, $is_component = 0 ) {
+    return template_dir( $path, $ct, $is_component, 1 ) . "/$path";
+}
+
+=head2 forms_dir()
+
+dir_for() the post type forms directory, which is where the post type wizard
+writes new types and their schema sidecars.
+
+=cut
+
+sub forms_dir {
+    return dir_for( 'forms', 'text/html', 1 );
+}
+
+=head2 files_in_dir($path, $content_type, $is_component, $ext)
+
+Bare filenames with the given extension in whichever single directory dir_for()
+picks.  See themed_templates_in_dir() for the version which spans both.
+
+=cut
+
+sub files_in_dir ( $path, $ct, $is_component = 0, $ext = 'tx' ) {
+    return _read_dir( dir_for( $path, $ct, $is_component ), $ext );
+}
+
+sub _read_dir ( $dir, $ext ) {
+    my $files = [];
+    return $files unless -d $dir;
+    opendir( my $dh, $dir ) or return $files;
+    while ( my $file = readdir($dh) ) {
+        push( @$files, $file ) if -f "$dir/$file" && $file =~ m/\.\Q$ext\E$/;
+    }
+    closedir($dh);
+    return $files;
+}
+
+=head2 templates_in_dir($path, $content_type, $is_component)
+
+files_in_dir() restricted to templates.
+
+Beware that this only ever reads one directory -- see themed_templates_in_dir()
+for why that's usually not what you want.
+
+=cut
+
 sub templates_in_dir ( $path, $ct, $is_component = 0 ) {
-    $path = template_dir( $path, $ct, $is_component, 1 ) . "/$path";
-    my $forms = [];
-    return $forms unless -d $path;
-    opendir( my $dh, $path );
-    while ( my $form = readdir($dh) ) {
-        push( @$forms, $form ) if -f "$path/$form" && $form =~ m/.*\.tx$/;
+    return files_in_dir( $path, $ct, $is_component, 'tx' );
+}
+
+=head2 themed_templates_in_dir($path, $content_type, $is_component)
+
+Same calling convention as templates_in_dir(), but it doesn't make you pick a
+side: you get the theme's templates where the theme has them, plus the stock
+ones it hasn't overridden.
+
+templates_in_dir() resolves through template_dir(), which is winner-take-all --
+if a theme has a forms/ dir at all, its contents are the *only* post types the
+site can see, and every core one vanishes.  That's rarely what a theme author
+means by overriding a template.
+
+Returns bare filenames, deduped, theme first.  Which of the two files a given
+name resolves to is then up to whoever renders it -- see template_dirs().
+
+=cut
+
+sub themed_templates_in_dir ( $path, $ct, $is_component = 0 ) {
+    my @dirs = grep { $_ } map { "$_/$path" } _template_dirs( $ct, $is_component );
+
+    my ( @templates, %seen );
+    foreach my $dir (@dirs) {
+        foreach my $template ( @{ _read_dir( $dir, 'tx' ) } ) {
+
+            # First one wins, and the theme's dir comes first.
+            push( @templates, $template ) unless $seen{$template}++;
+        }
+    }
+    return \@templates;
+}
+
+=head2 themed_file_in_dir($path, $file, $content_type, $is_component)
+
+The path to a single named file in an abstract template dir, preferring the
+theme's copy.  Returns undef when neither has it.
+
+=cut
+
+sub themed_file_in_dir ( $path, $file, $ct, $is_component = 0 ) {
+    foreach my $dir ( grep { $_ } _template_dirs( $ct, $is_component ) ) {
+        return "$dir/$path/$file" if -f "$dir/$path/$file";
     }
-    close($dh);
-    return $forms;
+    return undef;
 }
 
 1;

lib/Trog/Vars.pm

@@ -6,8 +6,6 @@ use warnings;
 use feature qw{signatures};
 no warnings qw{experimental};
 
-use Ref::Util();
-use List::Util qw{any};
 
 #1MB chunks
 our $CHUNK_SEP  = 'tCMSep666YOLO42069';
@@ -33,91 +31,8 @@ our %cache_control = (
     static     => "public, max-age=604800, immutable",
 );
 
-our $not_ref = sub {
-    return !Ref::Util::is_ref(shift);
-};
-
-our $valid_cb = sub {
-    my $subname = shift;
-    my ($modname) = $subname =~ m/^([\w|:]+)::\w+$/;
-
-    # Modules always return 0 if they succeed!
-    eval { require $modname; } and do {
-        WARN("Post uses a callback whos module ($modname) cannot be found!");
-        return 0;
-    };
-
-    no strict 'refs';
-    my $ref = eval '\&' . $subname;
-    use strict;
-    return Ref::Util::is_coderef($ref);
-};
-
-our $hashref_or_string = sub {
-    my $subj = shift;
-    return Ref::Util::is_hashref($subj) || $not_ref->($subj);
-};
-
-# Shared Post schema
-our %schema = (
-    ## Parameters which must be in every single post
-    'title'      => $not_ref,
-    'callback'   => $valid_cb,
-    'tags'       => \&Ref::Util::is_arrayref,
-    'version'    => $not_ref,
-    'visibility' => $not_ref,
-    'aliases'    => \&Ref::Util::is_arrayref,
-
-    # title links here
-    'href' => $not_ref,
-
-    # Link to post locally
-    'local_href' => $not_ref,
-
-    # Post body
-    'data' => $not_ref,
-
-    # How do I edit this post?
-    'form' => $not_ref,
-
-    # Post is restricted to visibility to these ACLs if not public/unlisted
-    'acls' => \&Ref::Util::is_arrayref,
-    'id'   => $not_ref,
-
-    # Author of the post
-    'user'    => $not_ref,
-    'created' => $not_ref,
-);
-
-=head2 filter($data,[$schema]) = %$data_filtered
-
-Filter the provided data through the default schema, and optionally a user-provided schema.
-
-Remove unwanted params to keep data slim & secure.
-
-=cut
-
-sub filter ( $data, $user_schema = {} ) {
-    %$user_schema = (
-        %schema,
-        %$user_schema,
-    );
-
-    # Filter all the irrelevant data
-    foreach my $key ( keys(%$data) ) {
-
-        # We need to have the key in the schema, and it validate.
-        delete $data->{$key} unless List::Util::any { ( $_ eq $key ) && ( $user_schema->{$key}->( $data->{$key} ) ) } keys(%$user_schema);
-
-        #use Data::Dumper;
-        #print Dumper($data);
-
-        # All parameters in the schema are MANDATORY.
-        foreach my $param ( keys(%$user_schema) ) {
-            die "Missing mandatory parameter $param" unless exists $data->{$param};
-        }
-    }
-    return %$data;
-}
+# NOTE: the post schema and its validators used to be duplicated here as well
+# as in Trog::DataModule, and filter() had no callers at all.  Both are gone --
+# a post's shape is now an OpenAPIv3 schema, see Trog::DataModule::schema_for().
 
 1;

t/Trog-DataModule-schema.t

@@ -0,0 +1,259 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::MockModule qw{strict};
+use Test::Deep;
+use Test::Fatal qw{exception};
+use JSON::MaybeXS();
+use Path::Tiny();
+use FindBin;
+use feature qw{signatures};
+no warnings qw{experimental::signatures};
+
+use lib "$FindBin::Bin/../lib";
+
+require_ok('Trog::DataModule') or BAIL_OUT("Can't find SUT");
+require_ok('Trog::Routes::HTML');
+
+# Point the SUT at a temp forms dir we control and hand it whatever sidecars
+# each subtest wants.  The dir has to be real, as schema_for() keys its cache on
+# the dir's mtime.
+my $tempdir = Path::Tiny->tempdir();
+my %sidecars;
+
+my $thememock = Test::MockModule->new('Trog::Themes');
+$thememock->redefine( 'template_dirs', sub { ("$tempdir") } );
+$thememock->redefine(
+    'themed_file_in_dir',
+    sub ( $path, $file, @ ) {
+        return -f "$tempdir/$file" ? "$tempdir/$file" : undef;
+    }
+);
+
+# The logger isn't initialized outside of a running server.
+my $logmock = Test::MockModule->new('Trog::DataModule');
+$logmock->redefine( 'WARN', sub { note(shift) } );
+
+my $slurpmock = Test::MockModule->new('File::Slurper');
+$slurpmock->redefine( 'read_text', sub { $sidecars{ Path::Tiny::path(shift)->basename } } );
+
+# -f has to agree with %sidecars, and the dir mtime has to move, or the
+# mtime-keyed cache will hand back a stale answer.
+my $generation = 0;
+sub set_sidecars {
+    %sidecars = @_;
+    $tempdir->child($_)->remove foreach map { $_->basename } $tempdir->children();
+    $tempdir->child($_)->spew_utf8('{}') foreach keys %sidecars;
+    $generation++;
+    utime( time() + $generation, time() + $generation, "$tempdir" );
+    return;
+}
+
+sub sidecar { return JSON::MaybeXS::encode_json( { type => 'object', @_ } ) }
+
+subtest 'the base schema applies with no sidecar at all' => sub {
+    set_sidecars();
+
+    my $schema = Trog::DataModule::schema_for('blog.tx');
+    ok( exists $schema->{properties}{title},   "base properties are there" );
+    ok( !exists $schema->{properties}{gravy},  "and nothing else is" );
+    ok( !exists $schema->{required},           "an empty required list isn't emitted - it isn't legal OpenAPI" );
+
+    is_deeply(
+        Trog::DataModule::schema_for(''),
+        $schema,
+        "a post with no form still gets the base schema"
+    );
+};
+
+subtest 'a sidecar merges over the base' => sub {
+    set_sidecars(
+        'recipe.json' => sidecar(
+            required   => ['servings'],
+            properties => { servings => { type => 'integer' }, vegan => { type => 'boolean' } },
+        )
+    );
+
+    my $schema = Trog::DataModule::schema_for('recipe.tx');
+    ok( exists $schema->{properties}{servings}, "the sidecar's fields are merged in" );
+    ok( exists $schema->{properties}{title},    "...without losing the base's" );
+    is_deeply( $schema->{required}, ['servings'], "required carries over" );
+
+    ok( !exists Trog::DataModule::schema_for('blog.tx')->{properties}{servings},
+        "and they don't leak onto another post type" );
+};
+
+subtest 'sidecars cannot redefine core post fields' => sub {
+    set_sidecars(
+        'evil.json' => sidecar(
+            properties => {
+                id       => { type => 'object' },
+                acls     => { type => 'string' },
+                callback => { type => 'string' },
+            },
+        )
+    );
+
+    my $schema = Trog::DataModule::schema_for('evil.tx');
+    is( $schema->{properties}{id}{type},       'string',   "id keeps its own type" );
+    is( $schema->{properties}{acls}{type},     'array',    "acls stays an array" );
+    is( $schema->{properties}{callback}{type}, 'callback', "callback keeps the type that actually checks the sub exists" );
+};
+
+subtest 'a malformed sidecar is skipped, not fatal' => sub {
+    set_sidecars( 'busted.json' => '{ this is not json' );
+
+    my $schema;
+    is( exception { $schema = Trog::DataModule::schema_for('busted.tx') }, undef, "no exception" );
+    ok( exists $schema->{properties}{title}, "we fall back to the base schema" );
+};
+
+subtest 'the cache follows the forms dir mtime' => sub {
+    set_sidecars( 'recipe.json' => sidecar( properties => { servings => { type => 'integer' } } ) );
+    ok( exists Trog::DataModule::schema_for('recipe.tx')->{properties}{servings}, "declared" );
+
+    set_sidecars();
+    ok( !exists Trog::DataModule::schema_for('recipe.tx')->{properties}{servings},
+        "removing the sidecar is picked up without a restart" );
+};
+
+subtest 'validate() filters, coerces and reports' => sub {
+    set_sidecars(
+        'recipe.json' => sidecar(
+            properties => {
+                servings => { type => 'integer' },
+                vegan    => { type => 'boolean' },
+                photo    => { type => 'upload' },
+            },
+        )
+    );
+
+    my $post = {
+        form       => 'recipe.tx',
+        title      => 'Cookies',
+        visibility => 'public',
+        servings   => '12',
+        vegan      => '1',
+
+        # The router hands us plenty that was never a post field.
+        app   => 'junk',
+        to    => '/blog',
+        gravy => 'yes please',
+    };
+    is_deeply( [ Trog::DataModule::validate($post) ], [], "a good post has no errors" );
+    is( $post->{servings}, 12, "strings coerce to the declared type" );
+    isa_ok( $post->{vegan}, 'JSON::PP::Boolean', "checkbox values become real booleans" );
+    ok( !exists $post->{app} && !exists $post->{to} && !exists $post->{gravy}, "undescribed keys are filtered out" );
+
+    my ($error) = Trog::DataModule::validate( { form => 'recipe.tx', servings => 'lots' } );
+    like( $error, qr/servings/, "a bad value is reported rather than silently dropped" );
+
+    # 'upload' is our own sugar for the string-or-hashref an upload field is,
+    # depending on which direction it's travelling.
+    is_deeply( [ Trog::DataModule::validate( { form => 'recipe.tx', photo => { filename => 'x' } } ) ], [], "an upload hashref passes" );
+    is_deeply( [ Trog::DataModule::validate( { form => 'recipe.tx', photo => '/assets/x.jpg' } ) ],      [], "so does the href it becomes" );
+};
+
+subtest 'empty inputs are treated as absent, except for strings' => sub {
+    set_sidecars( 'recipe.json' => sidecar( properties => { servings => { type => 'integer' } } ) );
+
+    # An untouched number input submits '', which is not an integer and was
+    # never meant to be one.
+    my $post = { form => 'recipe.tx', servings => '', title => '' };
+    is_deeply( [ Trog::DataModule::validate($post) ], [], "no spurious type error" );
+    ok( !exists $post->{servings}, "the blank number is dropped" );
+    is( $post->{title}, '', "a blank string field is left exactly as it was before any of this was typed" );
+};
+
+subtest 'the custom types actually bite' => sub {
+    set_sidecars();
+
+    my ($bad) = Trog::DataModule::validate( { title => 'x', callback => 'Some::Random::Sub' } );
+    like( $bad, qr/cannot be loaded/, "a callback naming a module that isn't there is refused" );
+
+    is_deeply(
+        [ Trog::DataModule::validate( { title => 'x', callback => 'Trog::Routes::HTML::posts' } ) ],
+        [],
+        "a real one is fine"
+    );
+};
+
+subtest 'add() rejects a post that does not validate' => sub {
+    set_sidecars( 'recipe.json' => sidecar( required => ['servings'], properties => { servings => { type => 'integer' } } ) );
+
+    my $written;
+    {
+        no warnings qw{once};
+        @TestData::ISA = ('Trog::DataModule');
+        *TestData::get   = sub { return () };
+        *TestData::write = sub { $written = $_[1]; return 0 };
+    }
+
+    my $why = exception {
+        bless( {}, 'TestData' )->add( { form => 'recipe.tx', title => 'Cookies', visibility => 'public' } );
+    };
+    is( ref $why, 'ARRAY', "it dies with the error list, not a string" );
+    like( join( ' ', @$why ), qr/servings/, "which names the offending field" );
+
+    # A string die would come back wearing a Carp::Always stack trace, which is
+    # no use at all to whoever just submitted the form.
+    unlike( join( ' ', @$why ), qr/DataModule\.pm line/, "and carries no stack trace" );
+    ok( !$written, "nothing was written" );
+
+    bless( {}, 'TestData' )->add( { form => 'recipe.tx', title => 'Cookies', visibility => 'public', servings => '4' } );
+    is( $written->[0]{servings}, 4, "the good one went through, coerced" );
+};
+
+subtest '_wizard_fields zips the parallel arrays' => sub {
+
+    # The middle row was left blank.  Dropping it must not shift the type of
+    # the row after it -- this is the whole reason param_required is a select.
+    my $fields = Trog::Routes::HTML::_wizard_fields(
+        {
+            param_name        => [ 'Servings', '',     'cook_time', 'id',   'servings' ],
+            param_type        => [ 'number',   'text', 'textarea',  'text', 'text' ],
+            param_label       => [ 'Servings', '',     'Cook Time', 'ID',   'Dupe' ],
+            param_placeholder => [ '4',        '',     '45 min',    '',     '' ],
+            param_required    => [ 1,          0,      0,           0,      0 ],
+        }
+    );
+
+    is( scalar @$fields, 2, "blank, core-shadowing and duplicate rows are dropped" );
+    is( $fields->[0]{name},      'servings',  "names are lowercased" );
+    is( $fields->[0]{required},  1,           "required survives" );
+    is( $fields->[1]{name},      'cook_time', "the row after the blank one is still present" );
+    is( $fields->[1]{type},      'textarea',  "...with its own type, not the blank row's" );
+};
+
+subtest '_wizard_sidecar emits a usable OpenAPIv3 schema' => sub {
+    my $spec = Trog::Routes::HTML::_wizard_sidecar(
+        'recipe',
+        [
+            { name => 'servings',  type => 'number',   label => 'Servings',  placeholder => '4', required => 1 },
+            { name => 'vegan',     type => 'checkbox', label => 'Vegan?',    placeholder => '', required => 0 },
+        ],
+        ['inc_tags'],
+        'form_common.tx',
+    );
+
+    is( $spec->{type},                          'object',   "it's an object schema" );
+    is( $spec->{properties}{servings}{type},    'integer',  "a number input is an integer" );
+    is( $spec->{properties}{vegan}{type},       'boolean',  "a checkbox is a boolean" );
+    is_deeply( $spec->{required}, ['servings'], "only the required rows are required" );
+
+    # UI metadata rides along on x- keys so there's only one file to keep in sync.
+    is( $spec->{properties}{servings}{'x-tcms-label'},       'Servings', "labels are kept" );
+    is( $spec->{properties}{servings}{'x-tcms-placeholder'}, '4',        "so are placeholders" );
+    ok( !exists $spec->{properties}{vegan}{'x-tcms-placeholder'}, "but an empty placeholder isn't written out" );
+    is_deeply( $spec->{'x-tcms-post-type'}{includes}, ['tags.tx'], "the includes are recorded for regeneration" );
+};
+
+subtest '_kolon_safe defuses template syntax' => sub {
+    my $safe = Trog::Routes::HTML::_kolon_safe(qq{<: \$post.id :>\n: include "evil.tx";});
+    unlike( $safe, qr/</,      "no angle brackets survive" );
+    unlike( $safe, qr/[\r\n]/, "no newlines survive, so ':' can't start a directive" );
+    is( Trog::Routes::HTML::_kolon_safe( [] ), '', "a repeated param can't sneak a ref through" );
+};
+
+done_testing();

t/Trog-SQLite.t

@@ -19,6 +19,7 @@ subtest 'dbh' => sub {
     my $works = 0;
     no warnings qw{redefine once};
     local *TrogDBD::do = sub { $works };
+    local *TrogDBD::errstr = sub { 'bogus' };
 
     like(exception { Trog::SQLite::dbh('bogus','bogus') }, qr/ensure/i, "Failure to enforce schema throws");
     $works = 1;

t/Trog-Themes-themed-templates.t

@@ -0,0 +1,91 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::MockModule qw{strict};
+use Path::Tiny();
+use FindBin;
+
+use lib "$FindBin::Bin/../lib";
+
+require_ok('Trog::Themes') or BAIL_OUT("Can't find SUT");
+
+# A stock template tree and a theme which only partially overrides it.
+my $root  = Path::Tiny->tempdir();
+my $stock = $root->child('www/templates/html/components/forms');
+my $theme = $root->child('www/themes/spec/templates/html/components/forms');
+$_->mkpath foreach ( $stock, $theme );
+
+$stock->child($_)->spew_utf8("stock $_") foreach qw{blog.tx series.tx profile.tx blog.json series.json};
+$theme->child($_)->spew_utf8("themed $_") foreach qw{blog.tx gallery.tx blog.json};
+
+my $themedir = '';
+my $mock     = Test::MockModule->new('Trog::Themes');
+$mock->redefine( 'get_dir', sub { $themedir } );
+
+# $template_dir is what the stock tree hangs off; point it at the fixture.
+{
+    no warnings qw{once};
+    $Trog::Themes::template_dir = "$root/www/templates";
+}
+
+subtest 'with no theme, nothing changes' => sub {
+    $themedir = '';
+
+    is_deeply(
+        [ Trog::Themes::template_dirs( 'text/html', 1 ) ],
+        ["$root/www/templates/html/components"],
+        "only the stock dir is searched"
+    );
+
+    my $old = [ sort @{ Trog::Themes::templates_in_dir( 'forms', 'text/html', 1 ) } ];
+    my $new = [ sort @{ Trog::Themes::themed_templates_in_dir( 'forms', 'text/html', 1 ) } ];
+    is_deeply( $new, $old, "the themed helper agrees with the old one" );
+    is_deeply( $new, [qw{blog.tx profile.tx series.tx}], "...and lists the stock templates" );
+};
+
+subtest 'with a partial theme, the two disagree' => sub {
+    $themedir = "$root/www/themes/spec";
+
+    is_deeply(
+        [ Trog::Themes::template_dirs( 'text/html', 1 ) ],
+        [ "$root/www/themes/spec/templates/html/components", "$root/www/templates/html/components" ],
+        "the theme is searched first, then the stock tree"
+    );
+
+    # This is the shortcoming: one forms/ dir in a theme hides every stock
+    # post type the theme didn't happen to copy.
+    is_deeply(
+        [ sort @{ Trog::Themes::templates_in_dir( 'forms', 'text/html', 1 ) } ],
+        [qw{blog.tx gallery.tx}],
+        "templates_in_dir() sees only the theme's"
+    );
+
+    is_deeply(
+        [ sort @{ Trog::Themes::themed_templates_in_dir( 'forms', 'text/html', 1 ) } ],
+        [qw{blog.tx gallery.tx profile.tx series.tx}],
+        "themed_templates_in_dir() adds back the ones the theme didn't override"
+    );
+
+    my $listed = Trog::Themes::themed_templates_in_dir( 'forms', 'text/html', 1 );
+    is( scalar( grep { $_ eq 'blog.tx' } @$listed ), 1, "an overridden template is listed once, not twice" );
+    is( $listed->[0], 'blog.tx', "and the theme's copies come first" );
+};
+
+subtest 'themed_file_in_dir prefers the theme, falls back to stock' => sub {
+    $themedir = "$root/www/themes/spec";
+
+    is( Trog::Themes::themed_file_in_dir( 'forms', 'blog.json', 'text/html', 1 ),
+        "$theme/blog.json", "the theme's copy wins" );
+    is( Trog::Themes::themed_file_in_dir( 'forms', 'series.json', 'text/html', 1 ),
+        "$stock/series.json", "one the theme lacks falls back" );
+    is( Trog::Themes::themed_file_in_dir( 'forms', 'nope.json', 'text/html', 1 ),
+        undef, "and one nobody has is undef, not a path that doesn't exist" );
+};
+
+subtest 'an empty or missing dir is not fatal' => sub {
+    $themedir = "$root/www/themes/spec";
+    is_deeply( Trog::Themes::themed_templates_in_dir( 'nosuchdir', 'text/html', 1 ), [], "just an empty list" );
+};
+
+done_testing();

www/scripts/post_wizard.js

@@ -0,0 +1,32 @@
+// Post Type Wizard - repeatable custom field rows.
+//
+// Every row contributes exactly one param_name, param_type, param_label,
+// param_placeholder and param_required, so the five arrive server side as
+// aligned arrays.  This is why 'required' is a <select> and not a checkbox --
+// an unchecked checkbox submits nothing and would shift every later row.
+
+function addParam() {
+    var tpl  = document.getElementById('wizard-param-template');
+    var host = document.getElementById('wizard-params');
+    if ( tpl === null || host === null ) {
+        console.log('post wizard param template missing');
+        return false;
+    }
+    host.appendChild(document.importNode(tpl.content, true));
+    return false;
+}
+
+function delParam(button) {
+    var row = button.closest('.wizard-param-row');
+    if (row) {
+        row.parentNode.removeChild(row);
+    }
+    return false;
+}
+
+// Start with one blank row, otherwise the feature isn't discoverable.
+document.addEventListener("DOMContentLoaded", function(event) {
+    if ( document.getElementById('wizard-params') !== null ) {
+        addParam();
+    }
+});

www/templates/html/components/400.tx

@@ -1,3 +1,6 @@
 <h1>400 Bad Request</h1>
+: if ( $title != 'Bad Request' ) {
+<pre class="responsive-text"><: $title :></pre>
+: }
 <br /><br />
 See the SiteMap <a href="/sitemap">here</a> as to the valid ways to communicate with this website.

www/templates/html/components/forms/blog.json

@@ -0,0 +1,19 @@
+{
+   "x-tcms-post-type" : {
+      "name" : "blog",
+      "generated" : false,
+      "description" : "A long form post.  Body text and an optional preview image."
+   },
+   "type" : "object",
+   "properties" : {
+      "preview" : {
+         "type" : "string",
+         "x-tcms-label" : "Preview Image"
+      },
+      "preview_file" : {
+         "type" : "upload",
+         "x-tcms-label" : "Preview Image",
+         "x-tcms-input" : "file"
+      }
+   }
+}

www/templates/html/components/forms/dns.json

@@ -0,0 +1,9 @@
+{
+   "x-tcms-post-type" : {
+      "name" : "dns",
+      "generated" : false,
+      "description" : "Stub.  dns.tx is empty, so this type ingests nothing beyond the base post fields."
+   },
+   "type" : "object",
+   "properties" : {}
+}

www/templates/html/components/forms/entities.json

@@ -0,0 +1,18 @@
+{
+   "x-tcms-post-type" : {
+      "name" : "entities",
+      "generated" : false,
+      "description" : "A party to an invoice -- who to pay, and how."
+   },
+   "type" : "object",
+   "properties" : {
+      "payment_method" : {
+         "type" : "string",
+         "x-tcms-label" : "Payment Method"
+      },
+      "payment_details" : {
+         "type" : "string",
+         "x-tcms-label" : "Payment Details"
+      }
+   }
+}

www/templates/html/components/forms/file.json

@@ -0,0 +1,24 @@
+{
+   "x-tcms-post-type" : {
+      "name" : "file",
+      "generated" : false,
+      "description" : "An uploaded asset.  Renders as an image, audio or video player depending on its content type."
+   },
+   "type" : "object",
+   "properties" : {
+      "preview" : {
+         "type" : "string",
+         "x-tcms-label" : "Preview Image"
+      },
+      "preview_file" : {
+         "type" : "upload",
+         "x-tcms-label" : "Preview Image",
+         "x-tcms-input" : "file"
+      },
+      "file" : {
+         "type" : "upload",
+         "x-tcms-label" : "File",
+         "x-tcms-input" : "file"
+      }
+   }
+}

www/templates/html/components/forms/invoice.json

@@ -0,0 +1,33 @@
+{
+   "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"
+      },
+      "preview_file" : {
+         "type" : "upload",
+         "x-tcms-label" : "Preview Image",
+         "x-tcms-input" : "file"
+      },
+      "payee" : {
+         "type" : "string",
+         "x-tcms-label" : "Payee"
+      },
+      "payor" : {
+         "type" : "string",
+         "x-tcms-label" : "Payor"
+      },
+      "due_days" : {
+         "type" : "integer",
+         "minimum" : 0,
+         "x-tcms-label" : "Due in (days)",
+         "x-tcms-input" : "number"
+      }
+   }
+}

www/templates/html/components/forms/microblog.json

@@ -0,0 +1,31 @@
+{
+   "x-tcms-post-type" : {
+      "name" : "microblog",
+      "generated" : false,
+      "description" : "A short post pointing at something else, optionally with embedded audio or video."
+   },
+   "type" : "object",
+   "properties" : {
+      "preview" : {
+         "type" : "string",
+         "x-tcms-label" : "Preview Image"
+      },
+      "preview_file" : {
+         "type" : "upload",
+         "x-tcms-label" : "Preview Image",
+         "x-tcms-input" : "file"
+      },
+      "audio_href" : {
+         "type" : "string",
+         "x-tcms-label" : "Audio",
+         "x-tcms-input" : "url",
+         "x-tcms-placeholder" : "https://soundclod.com/static.mp3"
+      },
+      "video_href" : {
+         "type" : "string",
+         "x-tcms-label" : "Video",
+         "x-tcms-input" : "url",
+         "x-tcms-placeholder" : "https://youvimeo.tv/infomercial.mp4"
+      }
+   }
+}

www/templates/html/components/forms/presentation.json

@@ -0,0 +1,30 @@
+{
+   "x-tcms-post-type" : {
+      "name" : "presentation",
+      "generated" : false,
+      "description" : "A multi-page post rendered as a slide deck, with attachments referrable by index."
+   },
+   "type" : "object",
+   "properties" : {
+      "preview" : {
+         "type" : "string",
+         "x-tcms-label" : "Preview Image"
+      },
+      "preview_file" : {
+         "type" : "upload",
+         "x-tcms-label" : "Preview Image",
+         "x-tcms-input" : "file"
+      },
+      "video_href" : {
+         "type" : "string",
+         "x-tcms-label" : "Video",
+         "x-tcms-input" : "url",
+         "x-tcms-placeholder" : "https://youvimeo.tv/infomercial.mp4"
+      },
+      "attachments" : {
+         "type" : "array",
+         "items" : { "type" : "upload" },
+         "x-tcms-label" : "Attachments"
+      }
+   }
+}

www/templates/html/components/forms/profile.json

@@ -0,0 +1,46 @@
+{
+   "x-tcms-post-type" : {
+      "name" : "profile",
+      "generated" : false,
+      "description" : "A user.  Posts to /profile rather than /post/save, as it also drives Trog::Auth.",
+      "comment" : "'password' is deliberately absent: profile() strips it before the post is saved, and it must never reach the datastore."
+   },
+   "type" : "object",
+   "properties" : {
+      "preview" : {
+         "type" : "string",
+         "x-tcms-label" : "Avatar"
+      },
+      "preview_file" : {
+         "type" : "upload",
+         "x-tcms-label" : "Avatar",
+         "x-tcms-input" : "file"
+      },
+      "username" : {
+         "type" : "string",
+         "x-tcms-label" : "Username"
+      },
+      "display_name" : {
+         "type" : "string",
+         "x-tcms-label" : "Display Name"
+      },
+      "contact_email" : {
+         "type" : "email",
+         "x-tcms-label" : "Contact Email"
+      },
+      "wallpaper" : {
+         "type" : "string",
+         "x-tcms-label" : "Wallpaper"
+      },
+      "wallpaper_file" : {
+         "type" : "upload",
+         "x-tcms-label" : "Wallpaper",
+         "x-tcms-input" : "file"
+      },
+      "user_acls" : {
+         "type" : "array",
+         "items" : { "type" : "string" },
+         "x-tcms-label" : "User ACLs"
+      }
+   }
+}

www/templates/html/components/forms/series.json

@@ -0,0 +1,42 @@
+{
+   "x-tcms-post-type" : {
+      "name" : "series",
+      "generated" : false,
+      "description" : "A category of posts.  Owns an ACL, and dictates which post type its children use."
+   },
+   "type" : "object",
+   "required" : [ "aclname", "child_form" ],
+   "properties" : {
+      "preview" : {
+         "type" : "string",
+         "x-tcms-label" : "Preview Image"
+      },
+      "preview_file" : {
+         "type" : "upload",
+         "x-tcms-label" : "Preview Image",
+         "x-tcms-input" : "file"
+      },
+      "aclname" : {
+         "type" : "string",
+         "x-tcms-label" : "ACL name"
+      },
+      "child_form" : {
+         "type" : "string",
+         "pattern" : "^[A-Za-z0-9_-]+\\.tx$",
+         "x-tcms-label" : "Content Template"
+      },
+      "tiled" : {
+         "type" : "boolean",
+         "x-tcms-label" : "Tile Display?",
+         "x-tcms-input" : "checkbox"
+      },
+      "header" : {
+         "type" : "string",
+         "x-tcms-label" : "Header"
+      },
+      "footer" : {
+         "type" : "string",
+         "x-tcms-label" : "Footer"
+      }
+   }
+}

www/templates/html/components/forms/series.tx

@@ -33,7 +33,7 @@
         Title *<br /><input required class="cooltext" type="text" name="title" placeholder="Iowa Man Destroys Moon" value="<: $post.title :>" />
         URL *<br /><input required class="cooltext" type="text" name="local_href" placeholder="/someurl" value="<: $post.local_href :>" />
         ACL name *<br /><input required class="cooltext" type="text" name="aclname" value="<: $post.aclname :>" />
-        <label for="<: $post.id :>-tiled">Tile Display?<input id="<: $post.id :>-tiled" class="coolcb" type="checkbox" name="tiled" <: if ( $post.tiled ) { "checked" } :> /></label>
+        <label for="<: $post.id :>-tiled">Tile Display?<input id="<: $post.id :>-tiled" class="coolcb" type="checkbox" name="tiled" value="1" <: if ( $post.tiled ) { "checked" } :> /></label>
         <br />
         Content Template *<br />
         <select required class="cooltext" name="child_form">

www/templates/html/components/post_wizard.tx

@@ -1 +1,96 @@
-TEST
+<script type="text/javascript" src="/scripts/post_wizard.js"></script>
+<div id="backoffice">
+<p class="title">
+ Existing Post Types:
+</p>
+A "post type" is just a template living in <code>templates/html/components/forms/</code>.
+Every post picks exactly one of them &mdash; it's what the <em>Content Template</em> dropdown
+selects when you edit a Series.
+<hr />
+<ul id="existing-post-types">
+: for $forms -> $form {
+    <li><: $form :></li>
+: }
+</ul>
+<hr />
+<p class="title">
+ Create a new Post Type:
+</p>
+This writes a new template into the forms directory currently in use
+(<code><: $forms_dir :></code>) along with a matching <code>.json</code> sidecar describing
+any custom fields, so that the data model knows to keep them when a post is saved.
+<hr />
+
+<form class="Submissions" id="postTypeWizard" method="post" action="/admin/wyzzerdd/save">
+    Type Name * &mdash; letters, numbers, dash and underscore only<br />
+    <input required class="cooltext" type="text" name="name" pattern="[A-Za-z0-9_-]+" placeholder="recipe" value="<: $name :>" />
+
+    <p class="title">Canned Fields</p>
+    Most post types reuse the same handful of blocks.  Tick whichever ones this type needs.
+    <br />
+    <label for="wiz-wrapper">Wrap output in the standard post &lt;div&gt;<input id="wiz-wrapper" class="coolcb" type="checkbox" name="wrapper" value="1" <: $checked.wrapper :> /></label><br />
+    <label for="wiz-post_title">Post title &amp; permalink (post_title.tx)<input id="wiz-post_title" class="coolcb" type="checkbox" name="inc_post_title" value="1" <: $checked.inc_post_title :> /></label><br />
+    <label for="wiz-post_tags">Post tag list (post_tags.tx)<input id="wiz-post_tags" class="coolcb" type="checkbox" name="inc_post_tags" value="1" <: $checked.inc_post_tags :> /></label><br />
+    <label for="wiz-title_input">Title input in the editor<input id="wiz-title_input" class="coolcb" type="checkbox" name="inc_title_input" value="1" <: $checked.inc_title_input :> /></label><br />
+    <label for="wiz-preview">Preview image upload (preview.tx)<input id="wiz-preview" class="coolcb" type="checkbox" name="inc_preview" value="1" <: $checked.inc_preview :> /></label><br />
+    <label for="wiz-visibility">Visibility selector (visibility.tx)<input id="wiz-visibility" class="coolcb" type="checkbox" name="inc_visibility" value="1" <: $checked.inc_visibility :> /></label><br />
+    <label for="wiz-acls">ACL selector (acls.tx)<input id="wiz-acls" class="coolcb" type="checkbox" name="inc_acls" value="1" <: $checked.inc_acls :> /></label><br />
+    <label for="wiz-tags">Tag editor (tags.tx)<input id="wiz-tags" class="coolcb" type="checkbox" name="inc_tags" value="1" <: $checked.inc_tags :> /></label><br />
+    <label for="wiz-aliases">Alias URL editor (aliases.tx)<input id="wiz-aliases" class="coolcb" type="checkbox" name="inc_aliases" value="1" <: $checked.inc_aliases :> /></label><br />
+    <label for="wiz-attachments">Attachment uploader (attachments.tx)<input id="wiz-attachments" class="coolcb" type="checkbox" name="inc_attachments" value="1" <: $checked.inc_attachments :> /></label><br />
+
+    <br />
+    Title placeholder text<br />
+    <input class="cooltext" type="text" name="title_placeholder" placeholder="Iowa Man Destroys Moon" value="<: $title_placeholder :>" />
+
+    <br />
+    Content Body &mdash; this is always the last thing in the editor, and is what carries the post body itself.<br />
+    <select class="cooltext" name="body_form">
+        <option value="form_common.tx" <: $body_form == 'form_multi.tx' ? '' : 'selected' :> >Single page (form_common.tx)</option>
+        <option value="form_multi.tx" <: $body_form == 'form_multi.tx' ? 'selected' : '' :> >Multiple pages, like presentations (form_multi.tx)</option>
+    </select>
+
+    <p class="title">Custom Fields</p>
+    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.
+    <div id="wizard-params"></div>
+    <button type="button" style="float:right;" class="coolbutton" onclick="addParam(); return false;">Add Field</button>
+    <br style="clear:both;" />
+
+    <p class="title">Display Template</p>
+    <a href="https://metacpan.org/pod/Text::Xslate::Syntax::Kolon" title="GET UR MIND RITE">Kolon</a>
+    markup for how this post type renders when someone looks at it.
+    Use <code>&lt;: $post.yourfield :&gt;</code> for your custom fields, and
+    <code>&lt;: render_it($post.data) | mark_raw :&gt;</code> for the post body.
+    <br />
+    <textarea class="cooltext" name="display" rows="12" placeholder="&lt;div class=&quot;postData responsive-text&quot;&gt;&#10;    &lt;: render_it($post.data) | mark_raw :&gt;&#10;&lt;/div&gt;"><: $display :></textarea>
+
+    <br />
+    <label for="wiz-overwrite">Overwrite it if this type already exists?<input id="wiz-overwrite" class="coolcb" type="checkbox" name="overwrite" value="1" <: $checked.overwrite :> /></label>
+    <br />
+    <input type="submit" class="coolbutton" value="Create Post Type" />
+</form>
+
+<template id="wizard-param-template">
+    <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">
+            <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>
+        </select>
+        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">
+            <option value="0">Optional</option>
+            <option value="1">Required</option>
+        </select>
+        <button type="button" class="coolbutton" onclick="delParam(this); return false;">Remove</button>
+    </div>
+</template>
+</div>