tCMS/lib/Trog/Routes/HTML.pm

package Trog::Routes::HTML;

use 5.040;
use re '/aasx';
use warnings FATAL => 'all';

no warnings qw{once};

use POSIX qw{strftime};
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;

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 URI();
use URI::Escape();

use FindBin::libs;

use Trog::Log qw{:all};
use Trog::Utils;
use Trog::Config;
use Trog::Auth;
use Trog::Data;
use Trog::Themes;
use Trog::Bundle;
use Trog::Renderer;
use Trog::Email;
use Trog::DataSource;

use CGI::Cookie ();

our $landing_page = 'default.tx';

# Note to maintainers: never ever remove backends from this list.
# the auth => 1 is a crucial protection.
our %routes = (
    default => {
        callback => \&Trog::Routes::HTML::setup,
        nomap    => 1,
    },
    '/index' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::index,
    },

    # This should only be enabled to debug
    #    '/setup' => {
    #        method   => 'GET',
    #        callback => \&Trog::Routes::HTML::setup,
    #    },
    '/login' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::login,
        noindex  => 1,
    },
    '/logout' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::logout,
        noindex  => 1,
        nocache  => 1,
    },
    '/auth' => {
        method   => 'POST',
        callback => \&Trog::Routes::HTML::login,
        nocache  => 1,
        noindex  => 1,
    },
    '/totp' => {
        method => 'GET',
        auth   => 1,

        # The one page a user who has not enrolled yet is allowed to reach.
        totp_exempt => 1,
        callback    => \&Trog::Routes::HTML::totp,
    },
    '/secrets' => {
        method   => 'GET',
        auth     => 1,
        nocache  => 1,
        noindex  => 1,
        callback => \&Trog::Routes::HTML::secrets,
    },
    '/secrets/save' => {
        method   => 'POST',
        auth     => 1,
        nocache  => 1,
        noindex  => 1,
        callback => \&Trog::Routes::HTML::secrets_save,
    },
    '/secrets/forget' => {
        method   => 'POST',
        auth     => 1,
        nocache  => 1,
        noindex  => 1,
        callback => \&Trog::Routes::HTML::secrets_forget,
    },
    '/post/save' => {
        method   => 'POST',
        auth     => 1,
        callback => \&Trog::Routes::HTML::post_save,
    },
    '/post/delete' => {
        method   => 'POST',
        auth     => 1,
        callback => \&Trog::Routes::HTML::post_delete,
    },
    '/config/save' => {
        method   => 'POST',
        auth     => 1,
        callback => \&Trog::Routes::HTML::config_save,
    },
    '/themeclone' => {
        method   => 'POST',
        auth     => 1,
        callback => \&Trog::Routes::HTML::themeclone,
    },
    '/profile' => {
        method   => 'POST',
        auth     => 1,
        callback => \&Trog::Routes::HTML::profile,
    },
    '/manual' => {
        method   => 'GET',
        auth     => 1,
        callback => \&Trog::Routes::HTML::manual,
    },
    '/lib/{module+}' => {
        method   => 'GET',
        auth     => 1,
        callback => \&Trog::Routes::HTML::manual,
    },
    '/password_reset' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::resetpass,
        noindex  => 1,
    },

    # When we are logged in, we get a diff ver of the page.
    '/secure/password_reset' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::resetpass,
        auth     => 1,
    },
    '/request_password_reset' => {
        method   => 'POST',
        callback => \&Trog::Routes::HTML::do_resetpass,
        noindex  => 1,
        nocache  => 1,
    },
    '/processed' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::processed,
        noindex  => 1,
    },
    '/metrics' => {
        method   => 'GET',
        auth     => 1,
        callback => \&Trog::Routes::HTML::metrics,
    },
    '/admin/sessions' => {
        method   => 'GET',
        auth     => 1,
        callback => \&Trog::Routes::HTML::sessions,
        noindex  => 1,
        nocache  => 1,
    },

    # 'guest', not 'domain': the router sets $query->{domain} to the request's
    # own host *after* it applies the path parameters, so a variable by that
    # name never survives to the callback.
    '/guest/screenshot/{hypervisor}/{guest}' => {
        method   => 'GET',
        auth     => 1,
        callback => \&Trog::Routes::HTML::guest_screenshot,
        noindex  => 1,
        nocache  => 1,
    },
    '/guest/act' => {
        method   => 'POST',
        auth     => 1,
        callback => \&Trog::Routes::HTML::guest_act,
        noindex  => 1,
        nocache  => 1,
    },
    '/guest/reprovision' => {
        method   => 'POST',
        auth     => 1,
        callback => \&Trog::Routes::HTML::guest_reprovision,
        noindex  => 1,
        nocache  => 1,
    },

    # 'guest', not 'domain', for the reason the screenshot route names it that
    # way.
    '/guest/reprovision/log/{guest}' => {
        method     => 'GET',
        auth       => 1,
        callback   => \&Trog::Routes::HTML::guest_reprovision_log,
        robot_name => '/guest/reprovision/log/',
        noindex    => 1,
        nocache    => 1,
    },
    '/admin/wyzzerdd' => {
        method   => 'GET',
        auth     => 1,
        callback => \&Trog::Routes::HTML::post_wizard,
        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',
    => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::sitemap,
    },
    '/sitemap_index.xml',
    => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::sitemap,
        data     => { xml => 1 },
    },
    '/sitemap_index.xml.gz',
    => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::sitemap,
        data     => { xml => 1, compressed => 1 },
    },
    '/sitemap/static.xml' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::sitemap,
        data     => { xml => 1, map => 'static' },
    },
    '/sitemap/static.xml.gz' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::sitemap,
        data     => { xml => 1, compressed => 1, map => 'static' },
    },
    '/sitemap/{map}.xml' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::sitemap,
        data     => { xml => 1 },
    },
    '/sitemap/{map}.xml.gz' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::sitemap,
        data     => { xml => 1, compressed => 1 },
    },
    '/humans.txt' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::posts,
        data     => { tag => ['about'] },
    },
    '/styles/avatars.css' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::avatars,
        data     => { tag => ['about'] },
    },
    '/avatar/{avatar_hash}' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::libravatar,
        noindex  => 1,
        nocache  => 1,
    },
    '/favicon.ico' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::icon,
    },
    '/totp_qr/{file}' => {
        auth   => 1,
        method => 'GET',

        # The QR on that page, so it has to be reachable from it.
        totp_exempt => 1,
        callback    => \&Trog::Routes::HTML::totp_qr,
    },
    '/styles/rss-style.xsl' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::rss_style,
    },
    '/bundle/{version}/{names}.js' => {
        method   => 'GET',
        callback => \&Trog::Routes::HTML::bundle,
    },
);

# Grab theme routes
my $themed    = 0;
my $theme_dir = Trog::Themes::get_dir();
if ($theme_dir) {

    my $theme_mod = "$theme_dir/routes.pm";
    if ( -f $theme_mod ) {    ## no critic (ProhibitFiletest_f) -- theme routes, else the default theme
                              # get_dir() is relative to the tCMS root, which require only searches from '.'.
        local @INC = ( '.', @INC );
        require $theme_mod;
        @routes{ keys(%Theme::routes) } = values(%Theme::routes);
        $themed = 1;
    }
    else {
        # Use the special "default" theme
        require Theme;
    }
}

=head1 PRIMARY ROUTE

=head2 feedback_redirect($query, $to, $failure, $message)

Redirect to $to, carrying the outcome of a save so the destination page can put
it in the jsalert banner.

We redirect rather than rendering in place so that a save stays a
POST-redirect-GET -- refreshing the page the user lands on must not re-submit
the post.  That means the outcome has to travel in the URL, as there is nowhere
else to put it.

=cut

my sub feedback_redirect ( $query, $to, $failure, $message ) {
    my $cookie = feedback_cookie( $failure, $message );

    # Appended to what see_also() built rather than replacing it, so this still
    # logs and still redirects the way every other redirect in here does.
    my $response = $query->{tpsgi}->see_also($to);
    push( @{ $response->[1] }, 'Set-Cookie' => $cookie );

    return $response;
}

=head2 feedback_cookie($failure, $message) = STRING

The Set-Cookie which carries a save's outcome to the page it redirects to.

A cookie because a redirect's own headers are gone by the time the destination
renders, and a cookie is the one header that survives the hop.  It used to be a
query parameter, which meant a save's message was in the URL: a validation error
carrying a Carp::Always stack trace built a URL of several thousand characters,
and tPSGI answered the redirect it had just issued with a 419.  The user was
shown neither the page nor the error.

Trimmed to one line, because the banner puts it in a JS string literal, and
capped at $feedback_max characters, because a cookie has a size limit of its own
and nothing a person needs to read is longer than that.  The whole of it is in
the log either way.

=cut

our $feedback_max = 512;

sub feedback_cookie ( $failure, $message ) {
    $message //= '';
    $message =~ s/\s*\n+\s*/; /g;
    $message =~ s/;\s*$//;
    $message = substr( $message, 0, $feedback_max - 3 ) . '...' if length($message) > $feedback_max;

    my $value = ( $failure ? 1 : 0 ) . ':' . URI::Escape::uri_escape($message);

    # HttpOnly because the banner is rendered server side and no script has any
    # business reading it; Max-Age because a message nobody collected should not
    # follow them around; Path=/ because the destination is wherever they were.
    return "tcmsfeedback=$value; Path=/; HttpOnly; SameSite=Lax; Max-Age=30";
}

=head2 absorb_feedback($query)

Turn the parameters feedback_redirect() put in the URL back into the failure
and message the jsalert banner reads.

Done in index() rather than in each route, so that a save can hand feedback to
any destination that renders a page, whichever route ends up serving it.

=cut

my sub absorb_feedback ($query) {
    my ( $failure, $message ) = feedback_from_cookie( $query->{cookies} );

    # The query parameters are still read, for a redirect issued by a worker
    # which had not been restarted yet, and for anyone who has one bookmarked.
    if ( !defined $failure ) {
        my ( $saved, $failed ) = ( $query->{saved}, $query->{savefailed} );
        return unless defined $saved || defined $failed;

        $failure = defined $failed ? 1       : 0;
        $message = defined $failed ? $failed : $saved;
    }

    $query->{failure} = $failure;
    $query->{message} = $message || ( $failure ? 'Save failed.' : 'Saved.' );

    # A page showing a banner is not a page to cache: the banner is for the one
    # person who just saved something, and a static of it would be served to
    # everybody.  The query parameter form was accidentally safe here, since a
    # query string skips the render cache on its own; a cookie is not.
    $query->{nocache} = 1;

    # Read once.  Without this the banner reappears on every page until the
    # cookie expires.
    $query->{feedback_seen} = 1;

    # Nothing further to navigate to -- we are already there.  Without this the
    # banner's success branch would bounce us onwards.
    delete $query->{to};
    return;
}

=head2 feedback_from_cookie($cookies) = ($failure, $message)

Pull a save's outcome back out of the cookie feedback_redirect set.

Returns nothing when there isn't one, so that the caller can fall back to the
query parameters this replaced.

=cut

sub feedback_from_cookie ($cookies) {
    return () unless $cookies;

    local $@;
    my $jar = eval { CGI::Cookie->parse($cookies) };
    return () unless ref $jar eq 'HASH' && $jar->{tcmsfeedback};

    my $value = $jar->{tcmsfeedback}->value // '';
    my ( $failure, $message ) = $value =~ m/^([01]):(.*)$/s;
    return () unless defined $failure;

    return ( int($failure), URI::Escape::uri_unescape($message) );
}

my sub build_social_meta ( $query, $title ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 55 lines, which would overcomplicate index()
    return ( undef, undef, undef ) unless $query->{social_meta} && $query->{route} && $query->{domain};

    my $default_tags = $Theme::default_tags;
    $default_tags .= ',' . join( ',', @{ $query->{primary_post}->{tags} } ) if $default_tags && $query->{primary_post}->{tags};

    my $primary_data = ref $query->{primary_post}{data} eq 'ARRAY' ? $query->{primary_post}{data}[0] : $query->{primary_post}{data};
    my $meta_desc    = $primary_data // $Theme::description // "tCMS Site";
    $meta_desc = Trog::Utils::strip_and_trunc($meta_desc) || '';

    my $meta_tags = '';
    my $card_type = 'summary';
    $card_type = 'featured_image' if $query->{primary_post} && $query->{primary_post}{is_image};
    $card_type = 'player'         if $query->{primary_post} && $query->{primary_post}{is_video};

    my $image = $Theme::default_image ? "https://$query->{domain}/" . Trog::Themes::get_dir() . "/$Theme::default_image" : '';
    $image = "https://$query->{domain}/$query->{primary_post}{preview}" if $query->{primary_post} && $query->{primary_post}{preview};
    $image = "https://$query->{domain}/$query->{primary_post}{href}"    if $query->{primary_post} && $query->{primary_post}{is_image};

    my $primary_route = "https://$query->{domain}/$query->{route}";
    $primary_route =~ s/[\/]+/\//g;

    my $display_name = $Theme::display_name || 'Another tCMS Site';

    my $extra_tags = '';

    my %sopts = (
        site        => '',
        image       => '',
        fb_app_id   => '',
        site_name   => $display_name,
        app_name    => $display_name,
        title       => $title,
        description => $meta_desc,
        url         => $primary_route,
    );
    $sopts{site}      = $Theme::twitter_account if $Theme::twitter_account;
    $sopts{image}     = $image                  if $image;
    $sopts{fb_app_id} = $Theme::fb_app_id       if $Theme::fb_app_id;
    if ( $query->{primary_post} && $query->{primary_post}{is_video} ) {
        $sopts{player} = "https://$query->{domain}/$query->{primary_post}{href}";

        #XXX don't hardcode this
        $sopts{player_width}  = 1280;
        $sopts{player_height} = 720;
        $extra_tags .= "<meta property='og:video:type' content='$query->{primary_post}{content_type}' />\n";
    }
    my $social = HTML::SocialMeta->new(%sopts);
    $meta_tags = eval { $social->create($card_type) };
    $meta_tags =~ s/content="video"/content="video:other"/mg if $meta_tags;
    $meta_tags .= $extra_tags                                if $extra_tags;

    WARN("Theme misconfigured, social media tags will not be included: $@") if $theme_dir && !$meta_tags;
    return ( $default_tags, $meta_desc, $meta_tags );
}

my sub get_series ( $edit = 0 ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 13 lines, which would overcomplicate index()
    state $data;
    $data //= Trog::Data->new( Trog::Config::get() );

    my @series = $data->get(
        acls  => [qw{public}],
        tags  => [qw{topbar}],
        limit => 10,
        page  => 1,
    );
    @series = map { $_->{local_href} = "/post$_->{local_href}"; $_ } @series if $edit;
    return @series;
}

=head2 index

Implements the primary route used by all pages not behind auth.
Most subsequent functions simply pass content to this function.

=cut

sub index ( $query, $content = '', $i_styles = [], $i_scripts = [] ) {
    $query->{theme_dir} = Trog::Themes::td();

    absorb_feedback($query);

    my $to_render = $query->{template} // $landing_page;

    $content ||= Trog::Renderer->render( template => $to_render, data => $query, component => 1, contenttype => 'text/html' );
    return $content if ref $content eq "ARRAY";

    my @styles;
    unshift( @styles, qw{embed.css} ) if $query->{embed};
    unshift( @styles, qw{screen.css structure.css} );
    push( @styles, @$i_styles );
    my @p_styles = qw{structure.css print.css};
    unshift( @p_styles, qw{embed.css} ) if $query->{embed};

    my @series = get_series(0);

    my $title = $query->{primary_post}{title} // $query->{title} // $Theme::default_title // 'tCMS';

    # Handle link "unfurling" correctly
    my ( $default_tags, $meta_desc, $meta_tags ) = build_social_meta( $query, $title );

    #Do embed content
    my $tmpl = $query->{embed} ? 'embed.tx' : 'index.tx';
    $query->{theme_dir} =~ s/^\/www\///;

    # Grab the avatar class for the logged in user
    if ( $query->{user} ) {
        $query->{user_class} = Trog::Auth::username2classname( $query->{user} );
    }

    state $data;
    $data //= Trog::Data->new( Trog::Config::get() );

    my ( $search_lang, $search_help ) = search_language($query);

    # Consumed, so expire it: otherwise the banner reappears on every page the
    # reader visits until the cookie times out on its own.
    my %headers;
    %headers = ( 'Set-Cookie' => 'tcmsfeedback=; Path=/; HttpOnly; SameSite=Lax; Max-Age=0' ) if $query->{feedback_seen};

    return finish_render(
        $tmpl,
        {
            %$query,
            search_lang  => $search_lang,
            search_help  => $search_help,
            theme_dir    => Trog::Themes::td(),
            content      => $content,
            title        => $title,
            categories   => \@series,
            stylesheets  => \@styles,
            print_styles => \@p_styles,
            scripts      => $i_scripts,
            show_madeby  => $Theme::show_madeby ? 1 : 0,
            embed        => $query->{embed}     ? 1 : 0,
            embed_video  => $query->{primary_post}{is_video},
            default_tags => $default_tags,
            meta_desc    => $meta_desc,
            meta_tags    => $meta_tags,
        },
        %headers,
    );
}

my sub build_themed_styles ($styles) {
    my @styles = map { ( Trog::Themes::themed_style("$_") ) } @{ Trog::Utils::coerce_array($styles) };
    return \@styles;
}

=head1 NORMAL ROUTES

These are expected to either return a 200, or redirect to something which does.

=head2 setup

One time setup page; should only display to the first user to visit the site which we presume to be the administrator.

=cut

sub setup ($query) {
    File::Touch::touch("config/setup");
    return Trog::Renderer->render(
        template => 'notconfigured.tx',
        data     => {
            title       => 'tCMS Requires Setup to Continue...',
            stylesheets => build_themed_styles( ['notconfigured.css'] ),
            %$query,
        },
        contenttype => 'text/html',
        code        => 200,
    );
}

=head2 totp

Enable 2 factor auth via TOTP for the currently authenticated user.
Returns a page with a QR code & TOTP uri for pasting into your authenticator app of choice.

Every user has to enroll, so this is where a login without one lands and the only
page it can reach until it has one.  Showing the same enrollment again is the
point rather than a fallback: a user who lost their authenticator scans it again
and is back where they were.

=cut

sub totp ($query) {
    my $active_user = $query->{user};
    my $domain      = $query->{domain};
    $query->{failure} //= -1;
    my ( $uri, $qr, $failure, $message, $totp ) = Trog::Auth::totp( $active_user, $domain );

    my $now_tm     = time;
    my $now_string = strftime( "%a %b %e T%H:%M:%SZ %Y", gmtime($now_tm) );
    return Trog::Routes::HTML::index(
        {
            title     => 'Enable TOTP 2-Factor Auth',
            theme_dir => Trog::Themes::td(),
            uri       => $uri,
            qr        => $qr,
            failure   => $failure,
            message   => $message,
            template  => 'totp.tx',
            is_admin  => 1,
            cur_code  => $totp->expected_totp_code($now_tm),
            timestamp => $now_string,
            %$query,
        },
        undef,
        [qw{post.css}],
    );
}

my sub setup_initial_db ( $dat, $user, $display_name, $contact_email ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 72 lines, which would overcomplicate login()
    $dat->add(
        {
            "aclname"    => "series",
            "acls"       => [],
            "callback"   => "Trog::Routes::HTML::series",
            method       => 'GET',
            "data"       => "Series",
            "href"       => "/series",
            "local_href" => "/series",
            "preview"    => "/img/sys/testpattern.jpg",
            "tags"       => [qw{series topbar}],
            visibility   => 'public',
            "title"      => "Series",
            user         => $user,
            form         => 'series.tx',
            child_form   => 'series.tx',
            aliases      => [],
        },
        {
            "aclname"    => "about",
            "acls"       => [],
            "callback"   => "Trog::Routes::HTML::series",
            method       => 'GET',
            "data"       => "About",
            "href"       => "/about",
            "local_href" => "/about",
            "preview"    => "/img/sys/testpattern.jpg",
            "tags"       => [qw{series topbar public}],
            visibility   => 'public',
            "title"      => "About",
            user         => $user,
            form         => 'series.tx',
            child_form   => 'profile.tx',
            aliases      => [],
        },
        {
            "aclname"      => "config",
            acls           => [],
            "callback"     => "Trog::Routes::HTML::config",
            'method'       => 'GET',
            "content_type" => "text/html",
            "data"         => "Config",
            "href"         => "/config",
            "local_href"   => "/config",
            "preview"      => "/img/sys/testpattern.jpg",
            "tags"         => [qw{admin}],
            visibility     => 'private',
            "title"        => "Configure tCMS",
            user           => $user,
            aliases        => [],
        },
        {
            title         => $display_name,
            data          => 'Default user',
            preview       => '/img/avatar/humm.gif',
            wallpaper     => '/img/sys/testpattern.jpg',
            tags          => ['about'],
            visibility    => 'public',
            acls          => ['admin'],
            local_href    => "/users/$display_name",
            display_name  => $display_name,
            contact_email => $contact_email,
            callback      => "Trog::Routes::HTML::users",
            method        => 'GET',
            user          => $user,
            form          => 'profile.tx',
            aliases       => [],
        },
    );
    return 1;
}

=head2 login

Sets the user cookie if the provided user exists, or sets up the user as an admin with the provided credentials in the event that no users exist.

=cut

sub login ($query) {

    # Redirect if we actually have a logged in user.
    # Note to future me -- this user value is overwritten explicitly in server.psgi.
    # If that ever changes, you will die
    $query->{to} //= $query->{route};
    $query->{to} = '/config' if List::Util::any { $query->{to} eq $_ } qw{/login /logout};
    if ( $query->{user} ) {
        DEBUG("Login by $query->{user}, redirecting to $query->{to}");
        return $query->{tpsgi}->see_also( $query->{to} );
    }

    #Check and see if we have no users.  If so we will just accept whatever creds are passed.
    my $hasusers = -f "config/has_users";               ## no critic (ProhibitFiletest_f) -- a flag file, only ever touched
    my $btnmsg   = $hasusers ? "Log In" : "Register";

    my $headers;
    if ( $query->{username} && $query->{password} ) {
        if ( !$hasusers ) {

            # Make the first user
            Trog::Auth::useradd( $query->{username}, $query->{display_name}, $query->{password}, ['admin'], $query->{contact_email} );

            # Add a stub user page and the initial series.
            my $dat = Trog::Data->new( Trog::Config::get() );
            setup_initial_db( $dat, $query->{username}, $query->{display_name}, $query->{contact_email} );

            # Ensure we stop registering new users
            File::Touch::touch("config/has_users");
        }

        $query->{failed} = 1;
        my $cookie = Trog::Auth::mksession( $query->{username}, $query->{password}, $query->{token}, $query->{ip} // '' );
        if ($cookie) {

            # A login is how you get to enrol, since the QR is not something to
            # hand out to whoever asks for it -- so a user with no enrolment yet
            # gets a session and goes straight there rather than where they were
            # headed.  The dispatcher keeps them there until they have one.
            $query->{to} = '/totp' unless Trog::Auth::has_totp( $query->{username} );

            # TODO secure / sameSite cookie to kill csrf, maybe do rememberme with Expires=~0
            my $secure = '';
            $secure  = '; Secure' if $query->{scheme} eq 'https';
            $headers = {
                "Set-Cookie" => "tcmslogin=$cookie; HttpOnly; SameSite=Strict$secure",
            };
            $query->{failed} = 0;
        }
    }

    $query->{failed} //= -1;
    return Trog::Renderer->render(
        template => 'login.tx',
        data     => {
            title       => 'tCMS 2 ~ Login',
            to          => $query->{to},
            failure     => int( $query->{failed} ),
            message     => int( $query->{failed} ) < 1 ? "Login Successful, Redirecting..." : "Login Failed.",
            btnmsg      => $btnmsg,
            stylesheets => build_themed_styles( [qw{structure.css screen.css login.css}] ),
            theme_dir   => Trog::Themes::td(),
            has_users   => $hasusers,
            %$query,
        },
        headers     => $headers,
        contenttype => 'text/html',
        code        => 200,
        nocache     => $query->{nocache},
    );
}

=head2 logout

Deletes your users' session and opens the index.

=cut

sub logout ($query) {
    Trog::Auth::killsession( $query->{user}, $query->{ip} // '' ) if $query->{user};
    delete $query->{user};
    return Trog::Routes::HTML::index($query);
}

my sub get_themes {
    my $dir = 'www/themes';
    return [] unless -e $dir;
    return [ map { $_->basename } grep { $_->is_dir } Path::Tiny::path($dir)->children(qr/\A[^.]/) ];
}

=head2 config

Renders the configuration page, or redirects you back to the login page.

=cut

sub config ( $query = {} ) {
    return $query->{tpsgi}->see_also('/login') unless $query->{user};
    return $query->{tpsgi}->forbidden($query)  unless List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    $query->{failure} //= -1;

    return Trog::Routes::HTML::index(
        {
            title           => 'Configure tCMS',
            theme_dir       => Trog::Themes::td(),
            stylesheets     => [qw{config.css}],
            themes          => get_themes() || [],
            config_sections => config_sections(),
            message         => $query->{message},
            failure         => $query->{failure},
            to              => '/config',
            scheme          => $query->{scheme},
            is_admin        => 1,
            template        => 'config.tx',
            %$query,
        },
        undef,
        [qw{config.css}],
    );
}

# The settings which are a choice among what this instance actually has
# installed rather than free text.  default.cfg can say a key exists, but not
# that it has to be one of the themes on disk, so that part lives here.
my %config_choices = (
    'general.theme'      => sub { return [ '', @{ get_themes() || [] } ] },
    'general.data_model' => sub {
        foreach my $incdir (@INC) {
            my $dir = "$incdir/Trog/Data";
            next unless -d $dir;
            return [ map { $_->basename('.pm') } grep { -f } Path::Tiny::path($dir)->children(qr/[.]pm\z/) ];    ## no critic (ProhibitFiletest_f) -- building a menu of module names
        }
        die "Could not find tCMS data modules!  Is tCMS in \@INC?";
    },
);

my sub config_title ($name) {
    $name =~ s/[_-]/ /g;
    return join( ' ', map { ucfirst } split( ' ', $name ) );
}

=head2 config_sections() = ARRAYREF

The configuration editor's form, one entry per section of config/default.cfg,
each holding the fields that section describes:

    { section => 'general', title => 'General', fields => [ { name, key, title, comment, value, options, multiline } ] }

Fields carry the value this instance is running with, defaulting to what
default.cfg ships.  A field with 'options' renders as a menu, one with
'multiline' as a textarea -- a list of embed sources is not something to edit
through a one line input.

=cut

sub config_sections {
    my %configured = Trog::Config::get()->vars();

    my @sections;
    foreach my $section ( @{ Trog::Config::schema() } ) {
        my @fields;
        foreach my $field ( @{ $section->{fields} } ) {

            # A setting never configured takes the default, but one set to nothing
            # stays empty, or the editor would quietly restore the default to
            # anyone who cleared it.  XXX ACHTUNG config::simple's param() answers
            # a key which does not exist with a multi element array, so vars() is
            # what tells the two apart.  A key holding commas is an arrayref too.
            my $name = $field->{name};
            my $value =
               !exists $configured{$name}         ? $field->{default}
              : ref $configured{$name} eq 'ARRAY' ? join( ', ', @{ $configured{$name} } )
              : ref $configured{$name}            ? ''
              :                                     $configured{$name} // '';

            my %rendered = (
                %$field,
                title => config_title( $field->{key} ),
                value => $value,
            );

            if ( my $choices = $config_choices{ $field->{name} } ) {
                $rendered{options} = [
                    map {
                        {
                            value    => $_,
                            label    => $_           ? $_ : 'default',
                            selected => $_ eq $value ? 1  : 0,
                        }
                    } @{ $choices->() }
                ];
            }
            else {
                # Long values (an embed allowlist, a list of paths) are miserable
                # to edit in a box you can only see the end of.
                $rendered{multiline} = length($value) > 60 ? 1 : 0;
            }

            push( @fields, \%rendered );
        }
        push(
            @sections,
            {
                section => $section->{section},
                title   => config_title( $section->{section} ),
                fields  => \@fields,
            }
        );
    }
    return \@sections;
}

my sub stamp ($epoch) {
    my @t = localtime($epoch);
    return sprintf( '%04d-%02d-%02d %02d:%02d', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1] );
}

=head2 resetpass

=head2 do_resetpass

Routes for user service of their authentication details.

There is no route here for turning TOTP off.  Everybody has it, and losing an
authenticator is not a reason to stop having a second factor -- bin/totp reads a
user their existing enrollment back out of band, which is the same enrollment
rather than a new one.

=cut

=head2 secrets

=head2 secrets_save

=head2 secrets_forget

Implements /secrets, where a user manages what tCMS remembers on their behalf.

These are passwords that are not tCMS's -- the KeePass passphrase a provisioning
recipe's secret: values are behind, to begin with.  Storing one means the next
thing that needs it asks for a TOTP code instead, which is a thing you have on
you rather than a thing you have to have written down somewhere.

Everything here is that user's own.  There is no route by which one person's
secrets are listed, opened or deleted by another, admin included: the username
is taken from the session and never from the request, and it is bound into the
ciphertext, so a row is not readable as anybody but its owner.

Nothing ever renders a value back.  A secret you can read off a screen is one
you did not need us to keep -- if they have forgotten it, the answer is to
replace it, not to be shown it.

=cut

sub secrets ($query) {
    require Trog::Vault;

    my @secrets = map {
        my $secret = {%$_};
        $secret->{stored} = stamp( $secret->{created} );
        $secret->{used}   = $secret->{last_used} ? stamp( $secret->{last_used} ) : 'never';
        $secret
    } @{ Trog::Vault::list( $query->{user} ) };

    return Trog::Routes::HTML::index(
        {
            title       => 'Stored Secrets',
            theme_dir   => Trog::Themes::td(),
            template    => 'secrets.tx',
            stylesheets => [qw{config.css}],
            secrets     => \@secrets,
            has_vault   => Trog::Vault::has_key(),
            failure     => $query->{failure} // -1,
            %$query,
        },
        undef,
        [qw{config.css}],
    );
}

sub secrets_save ($query) {
    require Trog::Vault;

    my ( $ok, $message ) = Trog::Vault::set( $query->{user}, $query->{name} // '', $query->{secret} // '' );

    # This hash is cloned, logged around and handed to renderers.
    delete $query->{secret};

    return feedback_redirect( $query, '/secrets', $ok ? 0 : 1, $message );
}

sub secrets_forget ($query) {
    require Trog::Vault;

    my $name = $query->{name} // '';
    my $gone = Trog::Vault::forget( $query->{user}, $name );

    return feedback_redirect( $query, '/secrets', $gone ? 0 : 1, $gone ? "'$name' forgotten" : "there was nothing stored as '$name'" );
}

sub resetpass ($query) {
    $query->{failure} //= -1;

    my $is_admin = grep { $_ eq 'admin' } @{ $query->{user_acls} };

    return Trog::Routes::HTML::index(
        {
            title       => 'Request Authentication Resets',
            theme_dir   => Trog::Themes::td(),
            stylesheets => [qw{config.css}],
            message     => $query->{message},
            failure     => $query->{failure},
            scheme      => $query->{scheme},
            template    => 'resetpass.tx',
            is_admin    => $is_admin,
            %$query,
        },
        undef,
        [qw{config.css}],
    );
}

sub do_resetpass ($query) {
    my $user = $query->{username};

    # User Does not exist
    return $query->{tpsgi}->forbidden($query) if !Trog::Auth::user_exists($user);

    # User exists, but is not logged in this session
    return $query->{tpsgi}->forbidden($query) if !$query->{user} && Trog::Auth::user_has_session($user);

    my $token   = Trog::Utils::uuid();
    my $newpass = $query->{password} // Trog::Utils::uuid();
    my $res     = Trog::Auth::add_change_request( type => 'reset_pass', user => $user, secret => $newpass, token => $token );
    die "Could not add auth change request!" unless $res;

    # If the user is logged in, just do the deed, otherwise send them the token in an email
    if ( $query->{user} ) {
        return $query->{tpsgi}->see_also("/api/auth_change_request/$token");
    }
    Trog::Email::contact(
        $user,
        "root\@$query->{domain}",
        "$query->{domain}: Password reset URL for $user",
        { uri => "$query->{scheme}://$query->{domain}/api/auth_change_request/$token", template => 'password_reset.tx' }
    );
    return $query->{tpsgi}->see_also("/processed");
}

=head2 get_datasources

Every Trog::DataSource::* module on disk.

The wizard offers these as somewhere other than the datastore for a post type
to get its posts from, and post_wizard_save checks a submitted one against this
list -- the name ends up in a sidecar and is later require()d, so it has to be
something we found rather than something we were told.

=cut

sub get_datasources {
    my %found;
    foreach my $incdir (@INC) {
        my $dir = "$incdir/Trog/DataSource";
        next unless -d $dir;
        my @modules = eval {
            grep { -f } Path::Tiny::path($dir)->children(qr/[.]pm\z/);    ## no critic (ProhibitFiletest_f) -- building an allowlist of names
        } or next;
        $found{ "Trog::DataSource::" . $_->basename('.pm') } = 1 foreach @modules;
    }
    return [ sort keys(%found) ];
}

=head2 datasource_editable($module)

Whether a post type backed by $module should be given an editor.

A datasource says so with an EDITABLE method.  One that does not say is
assumed editable, since that is what a post type is unless it has a reason not
to be.

=cut

sub datasource_editable ($module) {
    return 1 unless $module;
    return 1 unless Trog::DataSource::load($module);
    return 1 unless $module->can('EDITABLE');
    return $module->EDITABLE ? 1 : 0;
}

=head2 config_save

Implements /config/save route.  Saves the configuration to config/main.cfg.

Only the keys config/default.cfg describes are saved, so a form which posts
something the defaults never heard of writes nothing -- the schema is what is
editable, not whatever turned up in the request.

=cut

sub config_save ($query) {
    return $query->{tpsgi}->see_also('/login') unless $query->{user};
    return $query->{tpsgi}->forbidden($query)  unless List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    my $conf = Trog::Config::get();
    config_apply( $conf, $query );

    $query->{failure} = 1;
    $query->{message} = "Failed to save configuration!";
    if ( $conf->write($Trog::Config::home_cfg) ) {
        $query->{failure} = 0;
        $query->{message} = "Configuration updated succesfully.";
    }

    #We need to reap the children with outdated configuration.
    $query->{tpsgi}->signal_restart_parent();

    return config($query);
}

=head2 config_apply( Config::Simple conf, HASHREF query )

Copy whatever settings the form posted onto $conf, keyed by their full
'section.key' name.

The schema is the allowlist: a request naming something config/default.cfg does
not describe writes nothing, so a stray form field cannot invent configuration.
Values are taken as posted, empty string included -- clearing a setting is how
you go back to having none.

=cut

sub config_apply ( $conf, $query ) {
    foreach my $section ( @{ Trog::Config::schema() } ) {
        foreach my $field ( @{ $section->{fields} } ) {
            my $value = $query->{ $field->{name} };
            next unless defined $value;

            # Duplicate inputs arrive as an array; the last one wins, same as
            # the browser's own idea of which field you filled in last.
            $value = $value->[-1] if ref $value eq 'ARRAY';
            next                  if ref $value;

            $conf->param( $field->{name}, $value );
        }
    }
    return;
}

=head2 themeclone

Clone a theme by copying a directory.

=cut

sub themeclone ($query) {
    return $query->{tpsgi}->see_also('/login') unless $query->{user};
    return $query->{tpsgi}->forbidden($query)  unless List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    my ( $theme, $newtheme ) = ( $query->{theme}, $query->{newtheme} );

    my $themedir = 'www/themes';

    $query->{failure} = 1;
    $query->{message} = "Failed to clone theme '$theme' as '$newtheme'!";
    require File::Copy::Recursive;
    if ( $theme && $newtheme && File::Copy::Recursive::dircopy( "$themedir/$theme", "$themedir/$newtheme" ) ) {
        $query->{failure} = 0;
        $query->{message} = "Successfully cloned theme '$theme' as '$newtheme'.";
    }
    return $query->{tpsgi}->see_also('/config');
}

=head2 post_save

Saves posts submitted via the /post pages

=cut

sub post_save ($qq) {
    return $qq->{tpsgi}->see_also('/login') unless $qq->{user};
    return $qq->{tpsgi}->forbidden($qq)     unless List::Util::any { $_ eq 'admin' } @{ $qq->{user_acls} };

    my $query = clone($qq);

    my $to = delete $query->{to};

    $query->{tags} = Trog::Utils::coerce_array( $query->{tags} );

    # Support data with multiple pages like presentations
    $query->{data}        = Trog::Utils::coerce_array( $query->{data} ) if $query->{data_is_array};
    $query->{attachments} = Trog::Utils::coerce_array( $query->{attachments} );

    # Filter bits and bobs XXX this is done deeper in, may require removal
    delete $query->{primary_post};
    delete $query->{social_meta};
    delete $query->{deflate};
    delete $query->{acls};

    # Ensure there are no null tags
    @{ $query->{tags} } = grep { defined $_ } @{ $query->{tags} };

    # Posts will always be GET
    $query->{method} = 'GET';

    state $data;
    $data //= Trog::Data->new( Trog::Config::get() );

    # 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", map { short_error($_) } @errors );

        # The full detail goes to the log; the user gets it in the banner on
        # the page they came from, rather than a dead-end 400.
        WARN("Rejected post from $qq->{user}: $why");
        return feedback_redirect( $qq, '/secure' . $to, 1, $why );
    };

    # Instruct tpsgi to invalidate the cached render.
    $qq->{tpsgi}->add_post_close_callback(
        sub {
            # XXX there is not a great way to find what needs to be re-rendered because posts can include other posts.
            # As such we just have to nuke all the .html renders.
            $qq->{tpsgi}->invalidate_renders('html');
        }
    );

    # Force a reload of the routing table
    $qq->{tpsgi}->signal_restart_parent();

    return feedback_redirect( $qq, '/secure' . $to, 0, "Saved post '$query->{title}'." );
}

=head2 profile

Saves / updates new users.

=cut

sub profile ($query) {
    return $query->{tpsgi}->see_also('/login') unless $query->{user};
    return $query->{tpsgi}->forbidden($query)  unless List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    # Find the user's post and edit it
    state $data;
    $data //= Trog::Data->new( Trog::Config::get() );

    my @userposts = $data->get( tags => ['about'], acls => [qw{admin}] );

    # Users are always self-authored, you see

    my $user_obj = List::Util::first { ( $_->{user} || '' ) eq $query->{username} } @userposts;

    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};
    delete $query->{password};

    # Use the display name as the title
    $query->{title} = $query->{display_name};

    my %merged = (
        %$user_obj,
        %$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 );
}

=head2 post_delete

deletes posts.

=cut

sub post_delete ($query) {
    return $query->{tpsgi}->see_also('/login') unless $query->{user};
    return $query->{tpsgi}->forbidden($query)  unless List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    state $data;
    $data //= Trog::Data->new( Trog::Config::get() );

    $data->delete($query) and die "Could not delete post";
    return $query->{tpsgi}->see_also( $query->{to} );
}

# Anything a type needs computed rather than merely fetched.  The sub is named
# in the sidecar, so validate it the same way a post's own callback field is --
# a sidecar naming an arbitrary sub is a privilege question, not a typo.
my sub enrich_callback ( $post, $query ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 33 lines, which would overcomplicate enrich_post()
    my $meta = Trog::DataModule::type_meta_for( $post->{form} );
    my $sub  = $meta->{'x-tcms-post-type'}{enrich};
    return if !$sub || ref $sub;

    my ($modname) = $sub =~ m/^([\w:]+)::\w+$/;
    if ( !$modname ) {
        WARN("Post type '$post->{form}' declares a malformed enrich sub '$sub'");
        return;
    }

    my $modpath = $modname;
    $modpath =~ s{::}{/}g;
    $modpath .= '.pm';

    local $@;
    eval { require $modpath; 1 } or do {
        WARN("Post type '$post->{form}' declares enrich sub '$sub', but $modname will not load: $@");
        return;
    };

    no strict 'refs';
    if ( !defined &{$sub} ) {
        WARN("Post type '$post->{form}' declares enrich sub '$sub', which does not exist");
        return;
    }

    my %extra = &{$sub}( $post, $query );
    use strict;

    @$post{ keys(%extra) } = values(%extra);
    return;
}

=head2 enrich_post($post, $query, $cache)

Resolve a post type's declared relations onto the post, and run its enrich sub
if it has one.

A type says what it depends on in its sidecar rather than in code here -- see
Trog::DataModule::relations_for.  An entry naming a 'from' field resolves the
UUID in that field into the post it refers to; one without gets every post of
the target type, which is what an editor picker or a "show me all of these"
display wants.

$cache is a per-request memo of the per-type lookups.  Without it a page of
invoices re-scans every entities post once per invoice.

=cut

sub enrich_post ( $post, $query, $cache = {} ) {
    return unless Ref::Util::is_hashref($post) && $post->{form};

    my $relations = Trog::DataModule::relations_for( $post->{form} );
    foreach my $as ( keys(%$relations) ) {
        my $relation = $relations->{$as};
        next unless Ref::Util::is_hashref($relation);

        my ($target) = ( $relation->{form} // '' ) =~ m/^([\w-]+\.tx)$/;
        next unless $target;

        $cache->{$target} //= [ post_helper( { form => $target }, [], $query->{user_acls} ) ];

        # No 'from' means the relation is the whole set rather than one of them.
        my $from = $relation->{from};
        if ( !$from ) {
            $post->{$as} = $cache->{$target};
            next;
        }

        my $wanted = $post->{$from};
        $post->{$as} = defined $wanted ? List::Util::first { $_->{id} eq $wanted } @{ $cache->{$target} } : undef;
    }

    enrich_callback( $post, $query );
    return;
}

=head2 series

Series specific view, much like the users/ route
Displays identified series, not all series.

=cut

sub series ($query) {
    my $is_admin = grep { $_ eq 'admin' } @{ $query->{user_acls} };

    # rip away /secure if present
    $query->{route} =~ s|^/secure||;

    #we are either viewed one of two ways, /post/$id or /$aclname
    my ( undef, $aclname, $id ) = split( m{/}, $query->{route} );
    $query->{aclname} = $aclname if !$id;
    $query->{id}      = $id      if $id;

    # Don't show topbar series on the series page.  That said, don't exclude it from direct series view.
    $query->{exclude_tags} = ['topbar'] if !$is_admin && $aclname && $aclname eq 'series';

    #XXX I'd prefer to overload id to actually *be* the aclname...
    # but this way, accomodates things like the flat file time-indexing hack.
    # TODO I should probably have it for all posts, and make *everything* a series.
    # WE can then do threaded comments/posts.
    # That will essentially necessitate it *becoming* the ID for real.

    #Grab the relevant tag (aclname), then pass that to posts
    #
    # Deliberately not $query: this is looking up the one series post named by
    # the route, and handing it the reader's pagination pages *that* lookup.
    # Asking for page two of a single post gets nothing, so a series carrying a
    # ?page= in its URL could not find itself and 404'd on its own page.  Latent
    # until something started emitting page numbers -- see paginate_offset.
    my @posts = post_helper( { %$query, page => 1, limit => 1 }, ['series'], [ viewer_acls( $query, 1 ) ] );

    # The series post carries its *children's* relations, so that an editor
    # picker rendered on this page has something to populate from -- that is
    # what $primary_post.entities is on an invoice series.  Keyed on child_form
    # rather than form: the series is a series.tx, its children are what
    # declare the dependency.
    if ( $posts[0] ) {
        my $relations = Trog::DataModule::relations_for( $posts[0]{child_form} );
        if (%$relations) {

            # Resolve against a stand-in wearing the child's form, then copy
            # only the relation keys back, so nothing else about the series
            # post gets overwritten.
            my $stand_in = { %{ $posts[0] }, form => $posts[0]{child_form} };

            enrich_post( $stand_in, { %$query, user_acls => [ viewer_acls($query) ] } );
            @{ $posts[0] }{ keys(%$relations) } = @{$stand_in}{ keys(%$relations) };
        }
    }

    delete $query->{id};
    delete $query->{aclname};

    $query->{subhead}      = $posts[0]->{data};
    $query->{title}        = $posts[0]->{title};
    $query->{tag}          = $posts[0]->{aclname};
    $query->{primary_post} = $posts[0];
    $query->{in_series}    = 1;

    return posts($query);
}

=head2 avatars

Returns the avatars.css.

=cut

sub avatars ($query) {
    $query->{user_acls} = [ viewer_acls($query) ];
    my $tags = Trog::Utils::coerce_array( $query->{tag} );

    my @posts = post_helper( $query, $tags, $query->{user_acls} );
    if (@posts) {

        # Set the eTag so that we don't get a re-fetch
        $query->{etag} = "$posts[0]{id}-$posts[0]{version}";
    }

    @posts = map { $_->{id} =~ tr/-/_/; $_->{id} = "a_$_->{id}"; $_ } @posts;

    return Trog::Renderer->render(
        template => 'avatars.tx',
        data     => {
            users => \@posts,
            %$query,
        },
        code        => 200,
        contenttype => 'text/css',
    );
}

=head2 libravatar

Implements the libravatar protocol (https://wiki.libravatar.org/running_your_own/).
Accepts GET /avatar/{hash} where {hash} is the MD5 or SHA-256 of the user's
lowercased email address, and redirects to their profile avatar image.
Returns 404 when no matching user is found or the user has no avatar.

=cut

sub libravatar ($query) {
    my $hash = lc( $query->{avatar_hash} // '' );

    my $users = Trog::Auth::users_with_emails();
    my $matched_user;
    for my $u (@$users) {
        next unless $u->{contact_email};
        my $email = lc( $u->{contact_email} );
        if ( $hash eq sha256_hex($email) || $hash eq md5_hex($email) ) {
            $matched_user = $u->{name};
            last;
        }
    }

    return $query->{tpsgi}->notfound($query) unless $matched_user;

    my @posts   = post_helper( { author => $matched_user }, ['about'], [qw{public admin}] );
    my $preview = @posts ? $posts[0]->{preview} : '';

    return $query->{tpsgi}->notfound($query) unless $preview;

    return $query->{tpsgi}->redirect_permanent("/$preview");
}

=head2 users

Implements direct user profile view.

=cut

sub users ($query) {

    # rip away /secure if present
    $query->{route} =~ s|^/secure||;

    # Capture the username
    my ( undef, undef, $display_name ) = split( m{/}, $query->{route} );
    $display_name = URI::Escape::uri_unescape($display_name);

    my $username = Trog::Auth::display2username($display_name);
    return $query->{tpsgi}->notfound($query) unless $username;

    $query->{username} //= $username;
    $query->{user_acls}    = [ viewer_acls($query) ];
    $query->{exclude_tags} = ['about'];

    # Don't show topbar series on the series page.  That said, don't exclude it from direct series view.
    my $is_admin = grep { $_ eq 'admin' } @{ $query->{user_acls} };
    push( @{ $query->{exclude_tags} }, 'topbar' ) if !$is_admin;

    my @posts = post_helper( { author => $query->{username} }, ['about'], $query->{user_acls} );
    $query->{id}           = $posts[0]->{id};
    $query->{title}        = $posts[0]->{display_name};
    $posts[0]->{title}     = $posts[0]->{display_name};
    $query->{user_obj}     = $posts[0];
    $query->{primary_post} = $posts[0];
    $query->{in_series}    = 1;
    return posts($query);
}

my sub post2rss ( $rss, $url, $post ) {
    $rss->add_item(
        title       => $post->{title},
        permaLink   => $url,
        link        => $url,
        enclosure   => { url => $url, type => "text/html" },
        description => "<![CDATA[$post->{data}]]>",
        pubDate     => DateTime->from_epoch( epoch => $post->{created} ),    #TODO format like Thu, 23 Aug 1999 07:00:00 GMT
        author      => $post->{user},                                        #TODO translate to "email (user)" format
    );
    return 1;
}

my sub _rss ( $query, $subtitle, $posts ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 49 lines, which would overcomplicate posts()

    require XML::RSS;
    my $rss  = XML::RSS->new( version => '2.0', stylesheet => '/styles/rss-style.xsl' );
    my $now  = DateTime->from_epoch( epoch => time() );
    my $port = $query->{port} ? ":$query->{port}" : '';
    $rss->channel(
        title         => "$query->{domain}",
        subtitle      => $subtitle,
        link          => "http://$query->{domain}$port/$query->{route}?format=xml",
        language      => 'en',                                                        #TODO localization
        description   => "$query->{domain} : $query->{route}",
        pubDate       => $now,
        lastBuildDate => $now,
    );

    $rss->image(
        title       => $query->{domain},
        url         => "/favicon.ico",
        link        => "http://$query->{domain}$port",
        width       => 32,
        height      => 32,
        description => "$query->{domain} favicon",
    );

    foreach my $post (@$posts) {
        my $url = "http://$query->{domain}$port$post->{local_href}";
        post2rss( $rss, $url, $post );
        next unless ref $post->{aliases} eq 'ARRAY';
        foreach my $alias ( @{ $post->{aliases} } ) {
            $url = "http://$query->{domain}$port$alias";
            post2rss( $rss, $url, $post );
        }
    }

    return Trog::Renderer->render(
        template => 'raw.tx',
        data     => {
            etag   => $query->{etag},
            body   => encode_utf8( $rss->as_string ),
            scheme => $query->{scheme},
        },
        headers => { 'Content-Disposition' => 'inline; filename="rss.xml"' },

        #XXX if you do the "proper" content-type of application/rss+xml, browsers download rather than display.
        contenttype => "text/xml",
        code        => 200,
    );
}

=head2 posts

Display multi or single posts, supports RSS and pagination.

=cut

sub posts ( $query, $direct = 0 ) {

    # Before we build the render data, not after: posts.tx is rendered here and
    # handed to index() as content, so index()'s own absorb would be too late.
    absorb_feedback($query);

    # Allow rss.xml to tell what posts to loop over
    my $fmt = $query->{format} || '';

    #Process the input URI to capture tag/id
    $query->{route} //= $query->{to};

    # rip away /secure if present
    $query->{route} =~ s|^/secure||;

    my ( undef, undef, $id ) = split( m{/}, $query->{route} );

    my $tags = Trog::Utils::coerce_array( $query->{tag} );
    $query->{id} = $id if $id && !$query->{in_series};

    my $is_admin = grep { $_ eq 'admin' } @{ $query->{user_acls} };
    $query->{user_acls} = [ viewer_acls( $query, $query->{id} ) ];
    my @posts;

    # Discover this user's visibility, so we can make them post in this category by default
    my $user_visibility = 'public';

    if ( $query->{user_obj} ) {

        #Optimize the /users/* route
        @posts           = ( $query->{user_obj} );
        $user_visibility = $query->{user_obj}->{visibility};
    }
    else {
        if ( $query->{user} ) {
            my @me = post_helper( { author => $query->{user} }, ['about'], $query->{user_acls} );
            $user_visibility = $me[0]->{visibility};
        }
        @posts = post_helper( $query, $tags, $query->{user_acls} );
    }

    # A post type can say its posts come from somewhere other than the
    # datastore -- see Trog::DataSource::Virt, which builds them out of libvirt
    # guests.  The series is still an ordinary post; only its children are
    # synthesized, and they are rebuilt on every view rather than stored.
    @posts = datasource_posts( $query, \@posts );

    if ( $query->{id} ) {
        $query->{primary_post} = $posts[0] if @posts;
    }

    #OK, so if we have a user as the ID we found, go grab the rest of their posts
    if ( $query->{id} && @posts && List::Util::any { $_ eq 'about' } @{ $posts[0]->{tags} } ) {
        my $user       = shift(@posts);
        my $profile_id = delete $query->{id};
        $query->{author} = $user->{user};
        @posts           = post_helper( $query, $tags, $query->{user_acls} );
        @posts           = grep { $_->{id} ne $profile_id } @posts;
        unshift @posts, $user;
    }

    if ( !$is_admin ) {
        return $query->{tpsgi}->notfound($query) unless @posts;
    }

    # Set the eTag so that we don't get a re-fetch
    $query->{etag} = "$posts[0]{id}-$posts[0]{version}" if @posts;

    #Correct page headers
    my $ph = ( $themed && $Theme::paths{ $query->{route} } ) || $query->{route};

    return _rss( $query, $ph, \@posts ) if $fmt eq 'rss';

    # List the available headers/footers
    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 = [];

    # Build page title if it wasn't set by a wrapping sub
    $query->{title} = "$query->{domain} : $query->{title}" if $query->{title} && $query->{domain};
    $query->{title} ||= @$tags && $query->{domain} ? "$query->{domain} : @$tags" : undef;

    #Handle paginator vars
    $query->{limit} ||= 25;
    my $limit       = int( $query->{limit} );
    my $now_year    = ( localtime(time) )[5] + 1900;
    my $oldest_year = $now_year - 20;                  #XXX actually find oldest post year

    # Datasource pages page by offset, everything else by the created cursor.
    # See paginate_offset() for why they cannot share.
    my ( $paginate_offset, $page_of, $pages_total ) = ( 0, 1, 1 );
    if ( $query->{is_datasource} ) {
        $paginate_offset = 1;
        ( $page_of, $pages_total, @posts ) = paginate_offset( $query, $limit, @posts );
    }

    my $older = !@posts ? 0 : $posts[-1]->{created};
    $query->{failure} //= -1;
    $query->{id}      //= '';
    my $newer = !@posts ? 0 : $posts[0]->{created};

    #XXX messed up data has to be fixed unfortunately
    @$tags = List::Util::uniq @$tags;

    #Filter displaying visibility tags
    my @visibuddies = qw{public unlisted private};
    foreach my $post (@posts) {
        @{ $post->{tags} } = grep {
            my $tag = $_;
            List::Util::none { $tag eq $_ } @visibuddies
        } @{ $post->{tags} };
    }

    #XXX note that we are explicitly relying on the first tag to be the ACL
    my $aclselected = $tags->[0] || '';
    my @acls        = map {
        $_->{selected} = $_->{aclname} eq $aclselected ? 'selected' : '';
        $_
    } post_helper( {}, ['series'], $query->{user_acls} );

    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;

    state $data;
    $data //= Trog::Data->new( Trog::Config::get() );

    # Grab the rest of the tags to dump into the edit form
    my @tags_all = $data->tags();

    #Filter out the visibilities and special series tags
    @tags_all = grep {
        my $subj = $_;
        scalar( grep { $_ eq $subj } qw{public private unlisted admin series about topbar} ) == 0
    } @tags_all;

    @posts = map {
        my $subject = $_;
        my @et      = grep {
            my $subj = $_;
            grep { $subj eq $_ } @tags_all
        } @{ $subject->{tags} };
        @et = grep { $_ ne $aclselected } @et;
        $_->{extra_tags} = \@et;
        $_
    } @posts;
    my @et = List::MoreUtils::singleton( @$tags, @tags_all );

    $query->{author} = $query->{primary_post}{user} // $posts[0]{user};

    # Resolve each post's declared relations.  One cache for the whole page, so
    # 25 invoices don't mean 25 scans of every entities post.
    my %relation_cache;
    enrich_post( $_, $query, \%relation_cache ) foreach @posts;

    #XXX the only reason this is needed is due to direct=1
    # Last thing before the data becomes a page: anything a type marks private
    # goes no further for a reader who cannot edit.  Deliberately after the
    # datasource has run -- a datasource may well need a private field, like
    # the connection uri it takes to reach a hypervisor, to produce anything
    # at all.
    if ( !$is_admin ) {
        my %seen;
        redact_private( $_, \%seen ) foreach ( @posts, $query->{primary_post} );
    }

    #XXX is this even used?
    my $content = Trog::Renderer->render(
        template => 'posts.tx',
        data     => {
            acls              => \@acls,
            can_edit          => $is_admin,
            forms             => $forms,
            post              => { tags => $tags, extra_tags => \@et, form => $edittype, visibility => $user_visibility, addpost => 1 },
            post_visibilities => \@visibuddies,
            failure           => $query->{failure},
            to                => $query->{to},
            message           => $query->{message} // ( $query->{failure} ? "Failed to add post!" : "Successfully added Post as $query->{id}" ),
            direct            => $direct,
            title             => $query->{title},
            author            => $query->{primary_post}{user} // $posts[0]{user},
            primary_post      => $query->{primary_post},
            style             => $query->{style},
            posts             => \@posts,
            like              => $query->{like},
            in_series         => exists $query->{in_series} || !!( $query->{route} =~ m/^\/series\// ),
            route             => $query->{route},
            limit             => $limit,
            pages             => $paginate_offset ? $pages_total > 1 : scalar(@posts) == $limit,
            paginate_offset   => $paginate_offset,
            page              => $page_of,
            pages_total       => $pages_total,
            older             => $older,
            newer             => $newer,
            sizes             => [ 25, 50, 100 ],
            rss               => !$query->{id} && !$query->{older},
            tiled             => $tiled,
            category          => $ph,
            subhead           => $query->{subhead},
            headers           => $headers,
            footers           => $footers,
            years             => [ reverse( $oldest_year .. $now_year ) ],
            months            => [ 0 .. 11 ],
            embed             => $query->{embed},
            nochrome          => $query->{nochrome},
        },
        contenttype => 'text/html',
        component   => 1,
    );

    # Something exploded
    return $content if ref $content eq "ARRAY";

    return $content if $direct;
    my @scripts = ( ( $is_admin ? qw{post.js post_relations.js} : () ), qw{highlight.min.js reveal.min.js} );
    return Trog::Routes::HTML::index( $query, $content, $styles, \@scripts );
}

=head2 redact_private($post, $seen)

Drop the fields a post type marks private, for a reader who isn't an editor.

Done to the data on its way to the template rather than with a guard inside the
template: a type can be rendered by more than one template, templates get
edited by people who did not write the type, and a value that was never handed
over cannot be printed by mistake.  It walks into the post's relations too,
because they are posts and carry their own private fields.

=cut

sub redact_private ( $post, $seen = {} ) {
    my @todo = ($post);
    for ( my $i = 0; $i < scalar(@todo); $i++ ) {
        my $node = $todo[$i];
        next unless Ref::Util::is_hashref($node);

        # Relations can point back at what pulled them in.
        next if $seen->{$node}++;

        if ( $node->{form} ) {
            delete $node->{$_} foreach @{ Trog::DataModule::private_fields_for( $node->{form} ) };
        }

        foreach my $value ( values(%$node) ) {
            if    ( Ref::Util::is_hashref($value) )  { push( @todo, $value ) }
            elsif ( Ref::Util::is_arrayref($value) ) { push( @todo, @$value ) }
        }
    }
    return;
}

=head2 datasource_posts($query, $posts)

Swap a series' children for whatever its datasource says they are, if its child
type declares one.

Returns the posts unchanged for every ordinary type, which is nearly all of
them -- this is a hook, not a detour every page takes.

=cut

sub datasource_posts ( $query, $posts ) {
    my $series = $query->{primary_post};
    return @$posts unless Ref::Util::is_hashref($series) && $series->{child_form};

    my $source = Trog::DataSource::for_type( $series->{child_form} );
    return @$posts unless $source;
    return @$posts unless Trog::DataSource::load($source);

    my $builder = $source->can('posts');
    if ( !$builder ) {
        WARN("Datasource '$source' has no posts() to call");
        return @$posts;
    }

    local $@;
    my @synthesized = eval { $builder->( $series, $query ) };
    if ($@) {
        my $err = "$@";
        $err =~ s/\n.*//s;
        WARN("Datasource '$source' failed: $err");
        return @$posts;
    }

    # The search the reader typed was applied to the datastore by get(), and
    # then thrown away with the posts it filtered -- these are built fresh and
    # have never been near it.  Ask the source to apply it, or apply the default
    # on its behalf, so that searching a datasource page searches the page.
    my $filter = $source->can('filter') // \&Trog::DataSource::filter;

    my @filtered = eval { $filter->( $query, @synthesized ) };
    if ($@) {
        my $err = "$@";
        $err =~ s/\n.*//s;
        WARN("Datasource '$source' could not filter its posts: $err");
        @filtered = @synthesized;
    }

    # Pagination hands out page 2 of an order, so settle on one.
    my $order   = $source->can('order') // \&Trog::DataSource::order;
    my @ordered = eval { $order->( $query, @filtered ) };
    if ($@) {
        my $err = "$@";
        $err =~ s/\n.*//s;
        WARN("Datasource '$source' could not order its posts: $err");
        @ordered = @filtered;
    }

    # Which the paginator below reads, since these page by offset rather than by
    # the created cursor stored posts use.
    $query->{is_datasource} = 1;

    # A source which cannot say when its posts go stale must not have its pages
    # saved as statics: nothing else would ever invalidate them, so the cached
    # copy could never become right again.  See Trog::DataSource::cacheable.
    $query->{nocache} = 1 unless Trog::DataSource::cacheable($source);

    return @ordered;
}

=head2 paginate_offset($query, $limit, @posts) = ($page, $pages_total, @page_of_posts)

The slice of @posts the reader asked for, by page number.

Stored posts page by a cursor: the datastore is asked for the $limit posts older
than a timestamp, and the paginator hands back the oldest one on the page as the
next cursor.  That is the right shape when the alternative is reading the whole
datastore to skip most of it.

It is the wrong shape for a datasource, which has already built every post by
the time we see them -- and it does not work at all for one which stamps them
all with the time it built them, as libvirt guests are.  Every cursor on such a
page is the same instant, so Prev asks for everything older than now and gets
nothing.  Offset costs nothing here and moves.

=cut

sub paginate_offset ( $query, $limit, @posts ) {
    $limit = 25 if !$limit || $limit < 1;

    my $total       = scalar(@posts);
    my $pages_total = $total ? int( ( $total + $limit - 1 ) / $limit ) : 1;

    # Straight off a query string, so digits only -- the same coercion older and
    # newer get, rather than int() warning its way through a word.  Past the end
    # shows the last page rather than an empty one, which is what a stale
    # bookmark deserves.
    ( my $wanted = $query->{page} // '' ) =~ s/\D//g;
    my $page = $wanted ? int($wanted) : 1;
    $page = 1            if $page < 1;
    $page = $pages_total if $page > $pages_total;

    my $offset = ( $page - 1 ) * $limit;
    my @slice  = $offset < $total ? @posts[ $offset .. List::Util::min( $offset + $limit, $total ) - 1 ] : ();

    return ( $page, $pages_total, @slice );
}

=head2 search_language($query)

What to tell the reader the search box searches, as (language, help link).

The data model's answer describes what it can do to the datastore, which is the
right answer for nearly every page.  It is the wrong one for a page whose posts
are built by a datasource rather than read out of the datastore, so such a page
gets to say so.

=cut

sub search_language ($query) {
    state $data;
    $data //= Trog::Data->new( Trog::Config::get() );

    my $series = $query->{primary_post};
    my $source = Ref::Util::is_hashref($series) && $series->{child_form} ? Trog::DataSource::for_type( $series->{child_form} ) : undef;

    return ( $data->lang(), $data->help() ) unless $source && Trog::DataSource::load($source);

    my $lang = $source->can('lang') // \&Trog::DataSource::lang;
    my $help = $source->can('help') // \&Trog::DataSource::help;

    return ( scalar $lang->(), scalar $help->() );
}

=head2 viewer_acls($query, $direct) = LIST

The acls to fetch posts for this viewer with: their own, and public, plus
unlisted when the route names one post directly, plus private for an admin.
A logged out visitor holds no acls of their own, and would see nothing without
this.

=cut

sub viewer_acls ( $query, $direct = 0 ) {
    my @acls = ( @{ $query->{user_acls} // [] }, 'public' );
    push( @acls, 'unlisted' ) if $direct;
    push( @acls, 'private' )  if List::Util::any { $_ eq 'admin' } @acls;
    return List::Util::uniq(@acls);
}

=head2 post_helper($query, $tags, $acls) = LIST

The posts that a listing shows: those tagged one of @$tags that @$acls can
see, filtered and paged by the fields of $query.  page defaults to 1 and limit
to 25.  For a logged in user, each local_href is under /secure.

=cut

sub post_helper ( $query, $tags, $acls ) {
    state $data;
    $data //= Trog::Data->new( Trog::Config::get() );

    $query->{page}  ||= 1;
    $query->{limit} ||= 25;

    my @d = $data->get(
        older        => $query->{older},
        newer        => $query->{newer},
        page         => int( $query->{page} ),
        limit        => int( $query->{limit} ),
        tags         => $tags,
        exclude_tags => $query->{exclude_tags},
        acls         => $acls,
        aclname      => $query->{aclname},
        like         => $query->{like},
        author       => $query->{author},
        id           => $query->{id},
        version      => $query->{version},
        form         => $query->{form},
    );
    return map {
        my $subj = $_;
        $subj->{local_href} = "/secure$_->{local_href}";
        $subj
    } @d if $query->{user};
    return @d;
}

=head2 sitemap

Return the sitemap index unless the static or a set of dynamic routes is requested.
We have a maximum of 99,990,000 posts we can make under this model
As we have 10,000 * 10,000 posts which are indexable via the sitemap format.
1 top level index slot (10k posts) is taken by our static routes, the rest will be /posts.

Passing ?xml=1 will result in an appropriate sitemap.xml instead.
This is used to generate the static sitemaps as expected by search engines.

Passing compressed=1 will gzip the output.

=cut

sub sitemap ($query) {

    state $data;
    $data //= Trog::Data->new( Trog::Config::get() );

    state $etag = "sitemap-" . time();
    my ( @to_map, $is_index, $route_type );
    my $warning = '';
    $query->{map} //= '';
    if ( $query->{map} eq 'static' ) {

        # Return the map of static routes
        $route_type = 'Static Routes';
        @to_map     = grep { CORE::index( $_, '{' ) < 0 && !$routes{$_}->{auth} && !$routes{$_}->{noindex} && !$routes{$_}->{nomap} } keys(%routes);
    }
    elsif ( !$query->{map} ) {

        # Return the index instead
        @to_map = ('static');
        my $tot   = $data->count();
        my $size  = 50000;
        my $pages = int( $tot / $size ) + ( ( $tot % $size ) ? 1 : 0 );

        # Truncate pages at 10k due to standard
        my $clamped = $pages > 49999 ? 49999 : $pages;
        $warning = "More posts than possible to represent in sitemaps & index!  Old posts have been truncated." if $pages > 49999;

        foreach my $page ( $clamped .. 1 ) {
            push( @to_map, "$page" );
        }
        $is_index = 1;
    }
    else {
        $route_type = "Posts: Page $query->{map}";

        # Return the map of the particular range of dynamic posts
        $query->{limit} = 50000;
        $query->{page}  = $query->{map};
        @to_map         = post_helper( $query, [], ['public'] );
    }

    if ( $query->{xml} ) {
        DEBUG("RENDER SITEMAP XML");
        my $sm;
        my $xml_date = time();
        my $fmt      = "xml";
        $fmt .= ".gz" if $query->{compressed};
        if ( !$query->{map} ) {
            require WWW::SitemapIndex::XML;
            $sm = WWW::SitemapIndex::XML->new();
            foreach my $url (@to_map) {
                $sm->add(
                    loc     => "http://$query->{domain}/sitemap/$url.$fmt",
                    lastmod => $xml_date,
                );
            }
        }
        else {
            require WWW::Sitemap::XML;
            $sm = WWW::Sitemap::XML->new();
            my $changefreq = $query->{map} eq 'static' ? 'monthly' : 'daily';
            foreach my $url (@to_map) {
                my $true_uri = "http://$query->{domain}$url";
                if ( ref $url eq 'HASH' ) {
                    my $is_user_page = grep { $_ eq 'about' } @{ $url->{tags} };
                    $true_uri = "http://$query->{domain}/posts/$url->{id}";
                    $true_uri = "http://$query->{domain}/users/$url->{title}" if $is_user_page;
                }
                my %out = (
                    loc        => $true_uri,
                    lastmod    => $xml_date,
                    mobile     => 1,
                    changefreq => $changefreq,
                    priority   => 1.0,
                );

                if ( ref $url eq 'HASH' ) {

                    #add video & preview image if applicable
                    $out{images} = [
                        {
                            loc     => "http://$query->{domain}$url->{href}",
                            caption => $url->{data},
                            title   => substr( $url->{title}, 0, 100 ),
                        }
                      ]
                      if $url->{is_image};

                    # Truncate descriptions
                    my $desc    = substr( $url->{data}, 0, 2048 ) || '';
                    my $href    = $url->{href}                    || '';
                    my $preview = $url->{preview}                 || '';
                    my $domain  = $query->{domain}                || '';
                    $out{videos} = [
                        {
                            content_loc   => "http://$domain$href",
                            thumbnail_loc => "http://$domain$preview",
                            title         => substr( $url->{title}, 0, 100 ) || '',
                            description   => $desc,
                        }
                      ]
                      if $url->{is_video};
                }

                $sm->add(%out);
            }
        }
        my $xml = $sm->as_xml();
        require IO::String;
        my $buf = IO::String->new();
        my $ct  = 'application/xml';
        $xml->toFH( $buf, 0 );
        seek $buf, 0, 0;

        if ( $query->{compressed} ) {
            require IO::Compress::Gzip;
            my $compressed = IO::String->new();
            IO::Compress::Gzip::gzip( $buf => $compressed );
            $ct  = 'application/gzip';
            $buf = $compressed;
            seek $compressed, 0, 0;
        }

        #XXX This is one of the few exceptions where we don't use finish_render, as it *requires* gzip.
        return [ 200, [ "Content-type" => $ct, 'ETag' => $etag ], $buf ];
    }

    @to_map = sort @to_map unless $is_index;
    my $styles = ['sitemap.css'];

    $query->{title}      = "$query->{domain} : Sitemap";
    $query->{template}   = 'sitemap.tx';
    $query->{to_map}     = \@to_map;
    $query->{is_index}   = $is_index;
    $query->{route_type} = $route_type;
    $query->{etag}       = $etag;

    return Trog::Routes::HTML::index( $query, undef, $styles );
}

=head2 manual

Implements the /manual and /lib/* routes.

Basically a thin wrapper around Pod::Html.

=cut

sub manual ($query) {
    return $query->{tpsgi}->see_also('/login') unless $query->{user};
    return $query->{tpsgi}->forbidden($query)  unless List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    require Pod::Html;
    require Capture::Tiny;

    #Fix links from Pod::HTML
    $query->{module} =~ s/\.html$//g if $query->{module};
    $query->{failure} //= -1;

    my $infile = $query->{module} ? "$query->{module}.pm" : 'tCMS/Manual.pod';
    my $found  = 0;
    foreach my $libdir (@INC) {
        $found = $libdir if -f "$libdir/$infile";    ## no critic (ProhibitFiletest_f) -- which @INC dir supplies the pod
        last             if $found;
    }
    return $query->{tpsgi}->notfound($query) unless $found;

    my $content = capture { Pod::Html::pod2html( qw{--podpath=lib --podroot=.}, "--infile=$found/$infile" ) };

    return Trog::Routes::HTML::index(
        {
            title     => 'tCMS Manual',
            theme_dir => Trog::Themes::td(),
            content   => $content,
            template  => 'manual.tx',
            is_admin  => 1,
            %$query,
        },
        undef,
        ['post.css'],
    );
}

=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 {
    return Trog::Routes::HTML::index(
        {
            title     => "Your request has been processed",
            theme_dir => Trog::Themes::td(),
        },
        "Your request has been processed.<br /><br />You will recieve subsequent communications about this matter via means you have provided earlier.",
        ['post.css']
    );
}

=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 List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    $query->{failure} //= -1;

    return Trog::Routes::HTML::index(
        {
            title     => 'tCMS Metrics',
            theme_dir => Trog::Themes::td(),
            template  => 'metrics.tx',
            is_admin  => 1,
            %$query,
        },
        undef,
        ['post.css'],
        ['chart.min.js'],
    );
}

=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 List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    my $limit  = int( $query->{limit} // 100 );
    my $events = Trog::Auth::audit_log(
        limit      => $limit,
        username   => $query->{filter_user}  // '',
        event_type => $query->{filter_event} // '',
    );

    # Format timestamps for display
    @$events = map {
        my $e = {%$_};
        my @t = localtime( $e->{event_time} );
        $e->{event_ts}      = sprintf( '%04d-%02d-%02d %02d:%02d:%02d', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0] );
        $e->{session_short} = $e->{session_id} ? substr( $e->{session_id}, 0, 8 ) . '...' : '';
        $e
    } @$events;

    return Trog::Routes::HTML::index(
        {
            title        => 'tCMS Session Audit Log',
            theme_dir    => Trog::Themes::td(),
            template     => 'sessions.tx',
            is_admin     => 1,
            events       => $events,
            limit        => $limit,
            filter_user  => $query->{filter_user}  // '',
            filter_event => $query->{filter_event} // '',
            %$query,
        },
        undef,
        ['post.css'],
    );
}

# 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.
# Every post has a title, a visibility and a set of acls, so a type does not
# get to decide whether its editor collects them -- see post_wizard_save.
our @wizard_mandatory = qw{inc_title_input inc_visibility inc_acls};

our @wizard_optional_includes = grep {
    my $include = $_;
    List::Util::none { $include eq $_ } @wizard_mandatory
} @wizard_include_order;

# The checkboxes which are not editor includes: the wrapper div, and the two
# canned blocks a type splices into its display half.  Read back out of the
# template by wizard_display_of(), since %wizard_includes covers only the
# blocks that go into the editor.
our @wizard_display_checkboxes = qw{wrapper inc_post_title inc_post_tags};

our @wizard_checkboxes         = ( @wizard_display_checkboxes, @wizard_optional_includes, 'overwrite' );
our %wizard_checked_by_default = map { $_ => 1 } qw{wrapper inc_post_title inc_post_tags inc_preview 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 = (
    relation => { type => 'relation' },
    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};

# The hypervisor post a guest route was asked about.  Looked up rather than
# taken from the request: the connection URI is not something a form gets to
# hand us.
my sub guest_hypervisor ( $query, $id ) {
    return undef unless $id;
    my @found = post_helper( { id => $id }, [], $query->{user_acls} );
    return undef unless @found && ( $found[0]{conn_uri} // '' );
    return $found[0];
}

=head2 guest_screenshot

Implements GET /guest/screenshot/$hypervisor/$guest.  Admin only.

Served as its own route rather than inlined into the guest listing, so that a
page of guests renders immediately and the browser fetches the console
captures in parallel instead of us taking them one after another.

=cut

sub guest_screenshot ($query) {
    return $query->{tpsgi}->see_also('/login') unless $query->{user};
    return $query->{tpsgi}->forbidden($query)  unless List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    my $hypervisor = guest_hypervisor( $query, $query->{hypervisor} );
    return $query->{tpsgi}->notfound($query) unless $hypervisor;

    require Trog::DataSource::Virt;
    my ( $path, $why ) = Trog::DataSource::Virt::screenshot( $hypervisor, $query->{guest} );
    if ( !$path ) {
        WARN("Could not screenshot '$query->{guest}': $why");
        return $query->{tpsgi}->notfound($query);
    }

    return $query->{tpsgi}->serve(
        $query->{route},  $path, $query->{start}, $query->{streaming},
        $query->{ranges}, $query->{last_fetched}, $query->{deflate},
    );
}

=head2 guest_act

Implements POST /guest/act.  Admin only.

Powering a guest on or off, snapshotting it, or destroying it.  Separate from
everything that merely reads a guest, and the only route which reaches
Trog::DataSource::Virt::act.

=cut

sub guest_act ($query) {
    return $query->{tpsgi}->see_also('/login') unless $query->{user};
    return $query->{tpsgi}->forbidden($query)  unless List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    my $to = $query->{to} || '/';

    my $hypervisor = guest_hypervisor( $query, $query->{hypervisor} );
    return feedback_redirect( $query, $to, 1, 'No such hypervisor.' ) unless $hypervisor;

    require Trog::DataSource::Virt;

    # Same reason the screenshot route captures 'guest': a form field called
    # 'domain' would be overwritten by the router with the request's host.
    my ( $ok, $message ) = Trog::DataSource::Virt::act(
        $query->{action}, $hypervisor->{conn_uri}, $query->{guest}, $query->{user},
    );

    return feedback_redirect( $query, $to, $ok ? 0 : 1, "$query->{guest}: $message" );
}

=head2 guest_reprovision

Implements POST /guest/reprovision.  Admin only.

Rebuilding a guest from the recipe it was provisioned with: bin/provision in
trog-provisioner.  The only route which reaches
Trog::DataSource::ProvisionedVirt::reprovision.

This is not a recoverable operation, so read that function before changing
anything here.  It refuses for the guest tCMS is itself running on.

What the provisioner needs arrives with the request and never lands in this hash:
the passphrase to its secrets database, the sudo password on the hypervisor if
that login has no passwordless sudo, or a TOTP code which is spent and exchanged
for whichever of those they kept last time.

=cut

sub guest_reprovision ($query) {
    return $query->{tpsgi}->see_also('/login') unless $query->{user};
    return $query->{tpsgi}->forbidden($query)  unless List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    my $to = $query->{to} || '/';

    require Trog::DataSource::ProvisionedVirt;

    # 'guest' rather than 'domain', for the reason the screenshot route captures
    # it that way: the router overwrites $query->{domain} with the request's own
    # host, so a form field by that name never arrives.
    my ( $ok, $message ) = Trog::DataSource::ProvisionedVirt::reprovision(
        domain     => $query->{guest},
        user       => $query->{user},
        passphrase => $query->{passphrase},
        sudo       => $query->{sudo},
        totp       => $query->{totp},
        remember   => $query->{remember},
    );

    # Deleted rather than merely unused: this hash is cloned, logged around and
    # handed to renderers, and neither of these has any business in any of that.
    # The code as much as the passphrase -- it is spent by now, but a spent code
    # in a log is still a code somebody wrote down.
    delete $query->{$_} foreach qw{passphrase sudo totp};

    return feedback_redirect( $query, $to, $ok ? 0 : 1, ( $query->{guest} // 'guest' ) . ": $message" );
}

=head2 guest_reprovision_log

Implements GET /guest/reprovision/log/$guest.  Admin only.

The whole log of a guest's last reprovision, which the listing shows only the
tail of.  Nobody is waiting on the process which writes it, so this is the only
account of what happened there is.

Admin only and served rather than linked directly, because it lives in logs/
rather than under www/ -- and because the output of a provisioner is a
reasonable place for a hostname, an IP plan or a package list to turn up.

=cut

sub guest_reprovision_log ($query) {
    return $query->{tpsgi}->see_also('/login') unless $query->{user};
    return $query->{tpsgi}->forbidden($query)  unless List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    require Trog::DataSource::ProvisionedVirt;

    my $log = Trog::DataSource::ProvisionedVirt::log_for( $query->{guest} );
    return $query->{tpsgi}->notfound($query) unless defined $log;

    return Trog::Renderer->render(
        template    => 'reprovision_log.tx',
        contenttype => 'text/plain',
        code        => 200,
        data        => { %$query, body => $log },
    );
}

# Repeated params arrive as arrayrefs; anywhere we want one string, insist on one string.
my sub wizard_scalar ( $value = '' ) {
    return '' if !defined $value || ref $value;
    return $value;
}

=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 List::Util::any { $_ eq 'admin' } @{ $query->{user_acls} };

    $query->{failure} //= -1;

    # Get the existing post types
    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(
        {
            # 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(),
            types             => wizard_types_json($forms),
            type_names        => [ map { ( $_ =~ s/\.tx$//r ) } @$forms ],
            description       => wizard_description( $query->{description} ),
            datasources       => get_datasources(),
            datasource        => wizard_scalar( $query->{datasource} ),
            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'],
        ['post_wizard.js'],
    );
}

=head2 wizard_reindex($name, $fields)

Bring the data model's idea of which custom fields are queryable into line with
what the post types on disk declare.

Every type's indexed fields, not just the one that was saved: two types can
declare a field of the same name, so reconciling against one of them alone would
have saving that type drop the other's index.

The type being saved is taken from the field list in hand rather than by reading
back the sidecar just written.  schema_for() caches on the mtime of the forms
directory, which has one second of resolution, so a read here can legitimately
land on the generation before this save.

Returns the error if there was one, and nothing if all was well.  A failure to
index is not a failure to create the post type: the type is written by this
point, works, and is only missing an optimization.

=cut

my sub wizard_reindex ( $name, $fields ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 22 lines, which would overcomplicate post_wizard_save()
    my %indexed = map { $_->{name} => 1 } grep { $_->{indexed} } @$fields;

    my $this_type = "$name.tx";
    foreach my $form ( @{ Trog::Themes::themed_templates_in_dir( 'forms', 'text/html', 1 ) } ) {
        next if $form eq $this_type;
        $indexed{$_} = 1 foreach @{ Trog::DataModule::indexed_fields_for($form) };
    }

    local $@;
    eval {
        my $data = Trog::Data->new( Trog::Config::get() );
        $data->index_fields( sort keys %indexed );
        1;
    } or do {
        my $error = $@;
        WARN("Could not reconcile custom field indexes: $error");
        return $error;
    };

    return;
}

my sub wizard_fail ( $query, $message ) {
    WARN($message);
    return post_wizard(
        {
            %$query,
            wizard_submitted => 1,
            failure          => 1,
            message          => $message,
        }
    );
}

my sub wizard_field_html ($field) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 23 lines, which would overcomplicate wizard_template()
    my ( $n, $t, $l, $p ) = @$field{qw{name type label placeholder}};
    my $required = $field->{required} ? 'required ' : '';

    if ( $t eq 'relation' ) {

        # 'all' relations aren't stored, so there is nothing to edit.
        return '' if $field->{relation_mode} eq 'all';

        # Left empty on purpose: post_relations.js fills it from
        # /api/posts_of_form, so the picker can't go stale against the
        # generated template.
        return qq|            $l<br /><select ${required}class="cooltext relation-picker" name="$n" data-relation-form="$field->{relation_form}" data-selected="<: \$post.$n :>"></select>\n|;
    }

    return qq|            $l<br /><textarea ${required}class="cooltext" name="$n" placeholder="$p"><: \$post.$n :></textarea>\n|
      if $t eq 'textarea';

    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

my sub wizard_template ( $query, $fields, $includes, $body_form, $datasource = '' ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 54 lines, which would overcomplicate post_wizard_save()
    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";

    # A series can ask for its children to be tiled, which is a layout the
    # wrapper has to carry -- see how file.tx and series.tx do it.  Harmless
    # when the series hasn't asked, and it means a generated type gets tiling
    # for free rather than being the one kind of post that ignores the setting.
    $out .= qq|<div class="post <: \$style :> <: \$tiled ? 'tile' : '' :>">\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|;

    # A datasource can say its posts are built rather than written, in which
    # case an editor would be a form saving something nobody can edit -- and
    # for Trog::DataSource::Virt, one that writes a real post to sit alongside
    # the synthesized ones and collide with them.
    if ( !datasource_editable($datasource) ) {
        $out .= qq|</div>\n| if $query->{wrapper};
        return $out;
    }

    $out .= qq|\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;
}

=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 List::Util::any { $_ 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/^([\w-]+)$/;
    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();

    # -d only.  A -w here would check mode bits against our uid, which says
    # nothing about read-only mounts, ACLs or immutable flags -- and it is the
    # files, not the directory, that get written.  The eval around the two
    # spew_utf8 calls below reports the real errno when a write actually fails.
    return wizard_fail( $query, "Forms directory '$dir' does not exist." ) unless -d $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};

    # Whitelisted against what is actually on disk: this name goes into a
    # sidecar and is require()d later, so a regex is not enough.
    my $datasource = wizard_scalar( $query->{datasource} );
    if ( $datasource && List::Util::none { $_ eq $datasource } @{ get_datasources() } ) {
        return wizard_fail( $query, "'$datasource' is not a datasource I can find." );
    }

    my $fields = wizard_fields($query);

    # Not up for discussion.  A post with no visibility gets an undef pushed
    # into its tags by process, which is a tag nothing matches -- so the post
    # is invisible to everyone but an admin, for no reason anybody chose.  A
    # title and a set of acls are equally non-negotiable: every other form has
    # them, and a type whose editor cannot set them produces posts nobody can
    # title or restrict.
    $query->{$_} = 1 foreach @wizard_mandatory;

    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, $datasource,
        {
            description       => wizard_description( $query->{description} ),
            display           => wizard_scalar( $query->{display} ),
            title_placeholder => wizard_scalar( $query->{title_placeholder} ),
            map { $_ => $query->{$_} ? 1 : 0 } qw{wrapper inc_post_title inc_post_tags},
        }
    );

    local $@;
    eval {
        Path::Tiny::path($tx_file)->spew_utf8( wizard_template( $query, $fields, \@includes, $body_form, $datasource ) );
        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}");

    # Whatever the data model makes of an indexed field, it wants the whole
    # picture rather than this type's share of it -- see wizard_reindex.
    my $index_error = wizard_reindex( $name, $fields );
    return wizard_fail( $query, "Post type '$name' was written, but indexing its fields failed: $index_error" ) if $index_error;

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

=head2 short_error($error) = STRING

An error as a person should see it: the first line, without the file and line
number Perl glued onto the end.

add() dies with an arrayref of validation errors precisely so that they arrive
clean, but a failure further down -- a write that could not land, say -- is an
ordinary string die, and Carp::Always decorates those with the entire call
stack.  That whole thing used to go to the user.

The undecorated original is logged; this is only what reaches the banner.

=cut

sub short_error ( $error = '' ) {
    $error = "$error";
    $error =~ s/\n.*//s;
    $error =~ s/\s+at\s+\S+\s+line\s+\d+\.?\s*$//;
    return $error;
}

# What a type's template says about the parts of it the wizard emits itself
# rather than through %wizard_includes: the wrapper div, and the two canned
# blocks which go in the display half rather than in the editor.
#
# Undef when the template cannot be read at all, which is what leaves the
# sidecar as the fallback rather than making it a second opinion.  The template
# is what actually renders, so where the two disagree it is the template which
# is telling the truth.
my sub wizard_display_of ($form) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 26 lines, which would overcomplicate wizard_types()
    my $path = Trog::Themes::themed_file_in_dir( 'forms', $form, 'text/html', 1 );
    return undef unless $path;

    my $template = eval { File::Slurper::read_text($path) };
    return undef unless defined $template;

    my %shown = (
        inc_post_title => $template =~ m/^\s*:\s*include\s+"post_title\.tx"/m ? 1 : 0,
        inc_post_tags  => $template =~ m/^\s*:\s*include\s+"post_tags\.tx"/m  ? 1 : 0,
        wrapper        => 0,
    );

    # The wrapper is the first thing a type that has one emits, ahead of any
    # Kolon at all -- see wizard_template.  So only the first line with
    # anything on it is asked, and a type which opens with its own markup or its
    # own directive is one that ticked the box off.
    foreach my $line ( split( /\n/, $template ) ) {
        next                if $line =~ m/^\s*$/;
        next                if $line =~ m/^\s*<!--/;
        $shown{wrapper} = 1 if $line =~ m/^\s*<div\s+class="post\b/;
        last;
    }

    return \%shown;
}

# The custom fields of a type, as rows the wizard would have submitted.
my sub wizard_fields_of ( $schema, $meta, $includes = {} ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 72 lines, which would overcomplicate wizard_types()
    my $properties = $schema->{properties} // {};
    my %required   = map { $_ => 1 } @{ $schema->{required} // [] };
    my $relations  = $meta->{'x-tcms-relations'};
    $relations = {} unless Ref::Util::is_hashref($relations);

    # Whatever the canned blocks this type includes already collect.  These are
    # real fields of the type and really are in its schema, but nobody typed
    # them into the wizard, and offering them back as custom fields is how
    # ticking 'Preview image upload' and listing 'preview' as a text field came
    # to be the same thing said twice.
    my %canned;
    foreach my $include ( keys(%$includes) ) {
        my $collects = Trog::DataModule::include_schema_for($include)->{properties};
        next unless Ref::Util::is_hashref($collects);
        $canned{$_} = 1 foreach keys(%$collects);
    }

    my @fields;
    foreach my $name ( sort keys(%$properties) ) {

        # Only what this type added.  Everything in the base post schema belongs
        # to every post and was never a wizard field, and everything a canned
        # block collects belongs to the block rather than to the type.
        next if exists $Trog::DataModule::post_schema{properties}{$name};
        next if $canned{$name};

        my $property = $properties->{$name};
        next unless Ref::Util::is_hashref($property);

        push(
            @fields,
            {
                name          => $name,
                type          => $property->{'x-tcms-input'}       // 'text',
                label         => $property->{'x-tcms-label'}       // '',
                placeholder   => $property->{'x-tcms-placeholder'} // '',
                required      => $required{$name}              ? 1 : 0,
                private       => $property->{'x-tcms-private'} ? 1 : 0,
                indexed       => $property->{'x-tcms-indexed'} ? 1 : 0,
                relation_form => $property->{'x-tcms-relation-form'} // '',
                relation_mode => 'one',
            }
        );
    }

    # A relation pulling in every post of its target type stores nothing, so it
    # has no property to have been found above -- it exists only as a relations
    # entry with no 'from'.
    foreach my $name ( sort keys(%$relations) ) {
        my $relation = $relations->{$name};
        next unless Ref::Util::is_hashref($relation);
        next if $relation->{from};

        push(
            @fields,
            {
                name          => $name,
                type          => 'relation',
                label         => '',
                placeholder   => '',
                required      => 0,
                private       => 0,
                indexed       => 0,
                relation_form => $relation->{form} // '',
                relation_mode => 'all',
            }
        );
    }

    return \@fields;
}

=head2 wizard_display_from_template($form)

Recover a generated type's display template from the template itself.

For types written before the wizard started recording it in the sidecar.  Only
attempted for a file carrying the generated marker, and only between the two
lines wizard_template puts around it, so this either finds exactly what was
submitted or finds nothing.  A hand-written type finds nothing, which is correct:
there is no wizard form that produces one.

=cut

my sub wizard_display_from_template ($form) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 33 lines, which would overcomplicate wizard_types()
    my $path = Trog::Themes::themed_file_in_dir( 'forms', $form, 'text/html', 1 );
    return '' unless $path;

    my $template = eval { File::Slurper::read_text($path) };
    return '' unless defined $template;

    my @lines = split( /\n/, $template );

    # CORE::index because this package has an index() of its own -- the route
    # that renders every page.
    return '' if !@lines || CORE::index( $lines[0], 'Generated by the tCMS Post Type Wizard' ) == -1;

    my ( @display, $inside );
    foreach my $line (@lines) {
        if ( !$inside ) {
            $inside = 1 if $line =~ m/^\s*:\s*if\s*\(\s*!\$post\.addpost\s*\)\s*\{\s*$/;
            next;
        }

        last if $line =~ m/^\s*:\s*\}\s*$/;

        # The includes the wizard emitted, which are checkboxes rather than
        # anything the admin typed into the display box.
        next if $line =~ m/^\s*:\s*include\s+"/;

        push( @display, $line );
    }

    my $display = join( "\n", @display );
    $display =~ s/^\s+|\s+$//g;
    return $display;
}

=head2 wizard_types($forms) = HASHREF

Every post type on disk, in the shape the wizard's form is in.

This is the other direction from wizard_sidecar: it reads a type back out and
says what the wizard would have had to be told to produce it, so that picking one
from the dropdown can put the form into that state.

Everything but the display template and the canned includes comes out of the
sidecar.  The display comes out of the sidecar too for anything written since it
started being recorded there, and is read back out of the template itself
otherwise -- see wizard_display_from_template, and note that a hand-written type
will often yield nothing, which is honest: there is no wizard form that produces
it.

The includes always come out of the template, via
Trog::DataModule::includes_for(), since only a generated sidecar ever recorded
them.  That is also what tells the field list apart from the checkboxes: a
preview image is a field of every type which includes preview.tx, so it is that
box being ticked rather than a custom field somebody added.

=cut

sub wizard_types ($forms) {
    my %types;

    foreach my $form (@$forms) {
        my $schema = Trog::DataModule::schema_for($form);
        my $meta   = Trog::DataModule::type_meta_for($form);
        my $type   = $meta->{'x-tcms-post-type'};
        $type = {} unless Ref::Util::is_hashref($type);

        # What the editor actually splices in, which for a hand-written type is
        # the only account there is -- nothing but a generated sidecar records
        # the list.  Keyed on the template name, which is what %wizard_includes
        # maps a checkbox to.
        my %includes = map { $_ => 1 } @{ Trog::DataModule::includes_for($form) };

        my $display = $type->{display};
        $display = wizard_display_from_template($form) unless $display;

        # The wrapper div and the two blocks which belong to a type's display
        # half rather than to its editor.  Same reading as the includes, and for
        # the same reason: a hand-written type recorded none of it, and the
        # generated ones written before these were recorded did not either.
        my $shown = wizard_display_of($form) // { map { $_ => $type->{$_} ? 1 : 0 } @wizard_display_checkboxes };

        $types{$form} = {
            name        => ( $form =~ s/\.tx$//r ),
            description => $type->{description} // '',
            display     => $display             // '',

            # An include like any other -- see the bottom of wizard_template.  The
            # sidecar is the fallback, for a datasource type with no editor at all.
            body_form         => ( List::Util::first { $includes{$_} } qw{form_multi.tx form_common.tx} ) // $type->{body_form} // 'form_common.tx',
            datasource        => $meta->{'x-tcms-datasource'} // '',
            title_placeholder => $type->{title_placeholder}   // '',
            generated         => $type->{generated} ? 1 : 0,

            # The wizard's own checkboxes, every one of them an answer about
            # what the template does rather than about what the sidecar says.
            %$shown,
            ( map { $_ => $includes{ $wizard_includes{$_} } ? 1 : 0 } @wizard_optional_includes ),

            fields => wizard_fields_of( $schema, $meta, \%includes ),
        };
    }

    return \%types;
}

=head2 wizard_types_json($forms) = STRING

wizard_types() as JSON, safe to drop into a script element.

Every '<' is escaped, which is still valid JSON and means the string cannot
close the element it is sitting in -- a display template is full of markup, and
one containing the characters that end a script tag would otherwise end it.

=cut

sub wizard_types_json ($forms) {
    my $json = eval { JSON::MaybeXS->new( canonical => 1 )->encode( wizard_types($forms) ) };
    if ( !defined $json ) {
        WARN("Could not describe the existing post types: $@");
        return '{}';
    }

    $json =~ s/</\\u003c/g;
    return $json;
}

=head2 wizard_description($description)

A post type's description, as it goes into the sidecar.

Free text rather than template source: it is shown to whoever picks the type in
the wizard, and rendered as text, so the only thing to do to it is keep it a
sane length and stop it being something other than a string.

=cut

our $wizard_description_max = 2048;

sub wizard_description ( $description = '' ) {
    $description = wizard_scalar($description);
    $description = substr( $description, 0, $wizard_description_max ) if length($description) > $wizard_description_max;
    return $description;
}

=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 $rforms  = Trog::Utils::coerce_array( $query->{param_relation_form} );
    my $rmodes  = Trog::Utils::coerce_array( $query->{param_relation_mode} );
    my $private = Trog::Utils::coerce_array( $query->{param_private} );
    my $indexed = Trog::Utils::coerce_array( $query->{param_indexed} );

    my ( @fields, %seen );
    foreach my $index ( 0 .. $#$names ) {
        my ($fname) = lc( wizard_scalar( $names->[$index] ) ) =~ m/^([[:lower:]][[:lower:]\d_]{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 List::Util::any { $fname eq $_ } @wizard_reserved;

        my $type = wizard_scalar( $types->[$index] );
        $type = 'text' unless $wizard_field_types{$type};

        # A relation is only a relation if it names a target type that looks
        # like one; anything else falls back to being a plain text field.
        my ($rform) = wizard_scalar( $rforms->[$index] ) =~ m/^([\w-]+\.tx)$/;
        my $rmode = wizard_scalar( $rmodes->[$index] ) eq 'all' ? 'all' : 'one';
        $type = 'text' if $type eq 'relation' && !$rform;

        push(
            @fields,
            {
                name          => $fname,
                type          => $type,
                label         => kolon_safe( $labels->[$index] ) || ucfirst($fname),
                placeholder   => kolon_safe( $phs->[$index] ),
                required      => wizard_scalar( $reqs->[$index] ) ? 1 : 0,
                relation_form => $rform,
                relation_mode => $rmode,
                private       => wizard_scalar( $private->[$index] ) ? 1 : 0,
                indexed       => wizard_scalar( $indexed->[$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, $datasource = '', $extra = {} ) {
    my %properties;
    my @required;

    my %relations;

    foreach my $field (@$fields) {

        # A relation pulling in every post of its target type isn't a field the
        # post stores at all -- it is purely something injected at render, so
        # it gets a relations entry and no property.
        if ( $field->{type} eq 'relation' && $field->{relation_mode} eq 'all' ) {
            $relations{ $field->{name} } = { form => $field->{relation_form} };
            next;
        }

        my $property = { %{ $wizard_field_types{ $field->{type} } } };
        $property->{'x-tcms-input'}       = $field->{type};
        $property->{'x-tcms-label'}       = $field->{label};
        $property->{'x-tcms-placeholder'} = $field->{placeholder} if ( $field->{placeholder} // q{} ) ne q{};

        # Only written when it is true: a field is public unless it says so,
        # and a sidecar full of x-tcms-private:false reads like the opposite.
        $property->{'x-tcms-private'} = JSON::MaybeXS::true() if $field->{private};

        # Likewise unindexed unless asked for.  The sidecar is the declaration;
        # post_wizard_save() reconciles the data model against it.
        $property->{'x-tcms-indexed'} = JSON::MaybeXS::true() if $field->{indexed};

        if ( $field->{type} eq 'relation' ) {
            $property->{'x-tcms-relation-form'} = $field->{relation_form};

            # The stored field holds a UUID; the resolved post lands beside it.
            $relations{"$field->{name}_post"} = { form => $field->{relation_form}, from => $field->{name} };
        }

        $properties{ $field->{name} } = $property;
        push( @required, $field->{name} ) if $field->{required};
    }

    # Everything the wizard was told, so that picking this type again puts the
    # form back the way it was.  It all lives under x-tcms-post-type, which
    # schema_for() strips before validation -- the validator sees properties and
    # required and nothing else, so none of this can affect whether a post saves.
    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 ],
            description => $extra->{description} // '',
            display     => $extra->{display}     // '',

            # The checkboxes which are not includes, and so are not recoverable
            # from the list above.
            wrapper           => $extra->{wrapper}        ? JSON::MaybeXS::true() : JSON::MaybeXS::false(),
            inc_post_title    => $extra->{inc_post_title} ? JSON::MaybeXS::true() : JSON::MaybeXS::false(),
            inc_post_tags     => $extra->{inc_post_tags}  ? JSON::MaybeXS::true() : JSON::MaybeXS::false(),
            title_placeholder => $extra->{title_placeholder} // '',
        },
        type       => 'object',
        properties => \%properties,
    );
    $spec{required}            = \@required  if @required;
    $spec{'x-tcms-relations'}  = \%relations if %relations;
    $spec{'x-tcms-datasource'} = $datasource if $datasource;

    return \%spec;
}

# 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 bundle

Implements /bundle/{version}/{names}.js, the scripts of a page as one response.
See Trog::Bundle.

The body of a bundle is the same at a given href, so the browser keeps it.  An
href with an old version is redirected to the current one, so a page that was
cached before a script changed still gets its scripts.

=cut

sub bundle ($query) {
    my $bundle = Trog::Bundle::scripts( map { "$_.js" } split( /[+]/, $query->{names} ) );
    return $query->{tpsgi}->notfound($query) unless $bundle;
    return $query->{tpsgi}->redirect( $bundle->{href} ) if $query->{route} ne $bundle->{href};
    return [
        200,
        [
            'Content-type'  => 'text/javascript',
            'Cache-Control' => $Trog::Vars::cache_control{static},
        ],
        [ $bundle->{body} ],
    ];
}

=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 enrollment 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().
    return $query->{tpsgi}->serve(
        "totp/$fname",
        "totp/$fname",
        $query->{start},
        $query->{streaming},
        $query->{ranges},
        $query->{last_fetched},
        $query->{deflate},
    );
}

=head2 rss_style

Implements /styles/rss-style.xsl.

The XSL stylesheet which makes the RSS feed legible in a browser.

rss-style.tx pulls the header and footer in with component(), which works here
where an include directive would not: the output is XSL rather than HTML, so
the two are rendered separately and composed, and the header is asked for
without a doctype.

=cut

sub rss_style ($query) {
    $query->{port}       = ":$query->{port}" if $query->{port};
    $query->{title}      = qq{<xsl:value-of select="rss/channel/title"/>};
    $query->{no_doctype} = 1;

    return Trog::Renderer->render(
        template    => 'rss-style.tx',
        contenttype => 'text/xsl',
        data        => $query,
        code        => 200,
    );
}

=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, and hands the lot to Trog::Renderer.

The page's own template asks for the header and footer with component(), so the
resolved stylesheet and script lists are passed on to Trog::Component::Header
rather than being rendered into a string here.

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
    $vars->{lang}         //= 'en-US';
    $vars->{title}        //= 'tCMS';
    $vars->{stylesheets}  //= [];
    $vars->{print_styles} //= [qw{structure.css print.css}];
    $vars->{scripts}      //= [];

    # Theme-ize the paths
    $vars->{stylesheets}  = [ @{ build_themed_styles( $vars->{stylesheets} ) } ];
    $vars->{print_styles} = [ @{ build_themed_styles( $vars->{print_styles} ) } ];
    my $bundle = Trog::Bundle::scripts( @{ Trog::Utils::coerce_array( $vars->{scripts} ) } );
    $vars->{scripts} = $bundle ? [ $bundle->{href} ] : [];
    Trog::Bundle::save( $vars->{tpsgi}, $bundle ) if $bundle;

    # Add in avatars.css, it's special
    push( @{ $vars->{stylesheets} }, "/styles/avatars.css" );

    # Absolute-ize the paths for stylesheets
    @{ $vars->{stylesheets} }  = map { CORE::index( $_, '/' ) == 0 ? $_ : "/$_" } @{ $vars->{stylesheets} };
    @{ $vars->{print_styles} } = map { CORE::index( $_, '/' ) == 0 ? $_ : "/$_" } @{ $vars->{print_styles} };

    # TODO Smash together the stylesheets and minify

    $vars->{contenttype}  //= $Trog::Vars::content_types{html};
    $vars->{cachecontrol} //= $Trog::Vars::cache_control{revalidate};

    $vars->{code} ||= 200;
    $vars->{theme_dir} =~ s/^\/www\/// if $vars->{theme_dir};

    # %headers was accepted and then ignored, which nothing noticed because
    # nothing passed any.  index() passes one now, to expire the feedback cookie
    # once its message has been rendered.
    return Trog::Renderer->render(
        template    => $template,
        data        => $vars,
        contenttype => 'text/html',
        code        => $vars->{code},
        ( %headers ? ( headers => \%headers ) : () ),
    );
}

1;