package Trog::Routes::HTML;
use strict;
use warnings;
no warnings qw{experimental once};
use feature qw{signatures state};
use POSIX qw{strftime};
use Errno qw{ENOENT};
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 File::Basename qw{dirname};
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::FileHandler;
use Trog::Themes;
use Trog::Renderer;
use Trog::Email;
use Trog::Component::EmojiPicker;
our $landing_page = 'default.tx';
our $htmltitle = 'title.tx';
our $midtitle = 'midtitle.tx';
our $rightbar = 'rightbar.tx';
our $leftbar = 'leftbar.tx';
our $topbar = 'topbar.tx';
our $footbar = 'footbar.tx';
our $categorybar = 'categories.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,
callback => \&Trog::Routes::HTML::totp,
},
'/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/(.*)' => {
method => 'GET',
auth => 1,
captures => ['module'],
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,
},
'/request_totp_clear' => {
method => 'POST',
callback => \&Trog::Routes::HTML::do_totp_clear,
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/screenshot/(.*)/(.*)' => {
method => 'GET',
auth => 1,
callback => \&Trog::Routes::HTML::guest_screenshot,
# 'guest', not 'domain': the router sets $query->{domain} to the
# request's own host *after* it applies captures, so a capture by that
# name never survives to the callback.
captures => [qw{hypervisor guest}],
noindex => 1,
nocache => 1,
},
'/guest/act' => {
method => 'POST',
auth => 1,
callback => \&Trog::Routes::HTML::guest_act,
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/(.*).xml' => {
method => 'GET',
callback => \&Trog::Routes::HTML::sitemap,
data => { xml => 1 },
captures => ['map'],
},
'/sitemap/(.*).xml.gz' => {
method => 'GET',
callback => \&Trog::Routes::HTML::sitemap,
data => { xml => 1, compressed => 1 },
captures => ['map'],
},
'/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/(.*)' => {
method => 'GET',
callback => \&Trog::Routes::HTML::libravatar,
captures => ['avatar_hash'],
noindex => 1,
nocache => 1,
},
'/favicon.ico' => {
method => 'GET',
callback => \&Trog::Routes::HTML::icon,
},
'/totp_qr/(.*)' => {
auth => 1,
method => 'GET',
callback => \&Trog::Routes::HTML::totp_qr,
},
'/styles/rss-style.xsl' => {
method => 'GET',
callback => \&Trog::Routes::HTML::rss_style,
},
);
# 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 ) {
use lib '.';
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
sub _feedback_redirect ( $query, $to, $failure, $message ) {
# The banner puts this in a JS string literal, so it has to be one line.
$message //= '';
$message =~ s/\s*\n+\s*/; /g;
$message =~ s/;\s*$//;
my $sep = $to =~ m/\?/ ? '&' : '?';
my $key = $failure ? 'savefailed' : 'saved';
return $query->{tpsgi}->see_also( $to . $sep . $key . '=' . URI::Escape::uri_escape($message) );
}
=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
sub _absorb_feedback ($query) {
my ( $saved, $failed ) = ( $query->{saved}, $query->{savefailed} );
return unless defined $saved || defined $failed;
$query->{failure} = defined $failed ? 1 : 0;
$query->{message} = ( defined $failed ? $failed : $saved ) || ( $query->{failure} ? 'Save failed.' : 'Saved.' );
# 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 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\///;
# TO support theming we have to do things like this rather than with an include directive in the templates.
my $htmltitle = Trog::Renderer->render( template => $htmltitle, data => $query, component => 1, contenttype => 'text/html' );
return $htmltitle if ref $htmltitle eq 'ARRAY';
my $midtitle = Trog::Renderer->render( template => $midtitle, data => $query, component => 1, contenttype => 'text/html' );
return $midtitle if ref $midtitle eq 'ARRAY';
my $rightbar = Trog::Renderer->render( template => $rightbar, data => $query, component => 1, contenttype => 'text/html' );
return $rightbar if ref $rightbar eq 'ARRAY';
my $leftbar = Trog::Renderer->render( template => $leftbar, data => $query, component => 1, contenttype => 'text/html' );
return $leftbar if ref $leftbar eq 'ARRAY';
my $topbar = Trog::Renderer->render( template => $topbar, data => $query, component => 1, contenttype => 'text/html' );
return $topbar if ref $topbar eq 'ARRAY';
my $footbar = Trog::Renderer->render( template => $footbar, data => $query, component => 1, contenttype => 'text/html' );
return $footbar if ref $footbar eq 'ARRAY';
my $categorybar = Trog::Renderer->render( template => $categorybar, data => { %$query, categories => \@series }, component => 1, contenttype => 'text/html' );
return $categorybar if ref $categorybar eq 'ARRAY';
# 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());
return finish_render(
$tmpl,
{
%$query,
search_lang => $data->lang(),
search_help => $data->help(),
theme_dir => Trog::Themes::td(),
content => $content,
title => $title,
htmltitle => $htmltitle,
midtitle => $midtitle,
rightbar => $rightbar,
leftbar => $leftbar,
topbar => $topbar,
footbar => $footbar,
categorybar => $categorybar,
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,
}
);
}
sub _build_social_meta ( $query, $title ) {
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} = "$primary_route?embed=1";
$sopts{player} = "https://$query->{domain}/$query->{primary_post}{href}";
#XXX don't hardcode this
$sopts{player_width} = 1280;
$sopts{player_height} = 720;
$extra_tags .= "\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;
print STDERR "WARNING: Theme misconfigured, social media tags will not be included\n$@\n" if $theme_dir && !$meta_tags;
return ( $default_tags, $meta_desc, $meta_tags );
}
=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");
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.
=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}],
);
}
=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";
my $btnmsg = $hasusers ? "Log In" : "Register";
my $headers;
my $has_totp = 0;
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) {
# 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},
);
}
sub _setup_initial_db ( $dat, $user, $display_name, $contact_email ) {
$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 => [],
},
);
}
=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);
}
=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 grep { $_ eq 'admin' } @{ $query->{user_acls} };
$query->{failure} //= -1;
#XXX ACHTUNG config::simple has this brain damaged behavior of returning a multiple element array when you access something that does not exist.
#XXX straight up dying would be preferrable.
#XXX anyways, this means you can NEVER NEVER NEVER access a param from within a hash directly. YOU HAVE BEEN WARNED!
my $conf = Trog::Config::get();
state $theme = $conf->param('general.theme') // '';
state $dm = $conf->param('general.data_model') // 'DUMMY';
state $embeds = $conf->param('security.allow_embeds_from') // '';
state $hostname = $conf->param('general.hostname') // '';
return Trog::Routes::HTML::index(
{
title => 'Configure tCMS',
theme_dir => Trog::Themes::td(),
stylesheets => [qw{config.css}],
scripts => [qw{post.js}],
themes => _get_themes() || [],
data_models => _get_data_models(),
current_theme => $theme,
current_data_model => $dm,
message => $query->{message},
failure => $query->{failure},
to => '/config',
scheme => $query->{scheme},
embeds => $embeds,
is_admin => 1,
template => 'config.tx',
%$query,
hostname => $hostname,
},
undef,
[qw{config.css}],
);
}
=head2 resetpass
=head2 do_resetpass
=head2 do_totp_clear
Routes for user service of their authentication details.
=cut
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}],
scripts => [qw{post.js}],
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");
}
sub do_totp_clear ($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 $res = Trog::Auth::add_change_request( type => 'clear_totp', user => $user, 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 => 'totp_reset.tx' }
);
return $query->{tpsgi}->see_also("/processed");
}
sub _get_series ( $edit = 0 ) {
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;
}
sub _get_themes {
my $dir = 'www/themes';
opendir( my $dh, $dir ) || do { die "Can't opendir $dir: $!" unless $!{ENOENT} };
my @tdirs = grep { !/^\./ && -d "$dir/$_" } readdir($dh);
closedir $dh;
return \@tdirs;
}
sub _get_data_models {
foreach my $incdir (@INC) {
my $dir = "$incdir/Trog/Data";
next unless -d $dir;
opendir( my $dh, $dir ) || die "Can't opendir $dir: $!";
my @dmods = map { s/\.pm$//g; $_ } grep { /\.pm$/ && -f "$dir/$_" } readdir($dh);
closedir $dh;
return \@dmods;
}
die "Could not find tCMS data modules! Is tCMS in \@INC?";
}
=head2 config_save
Implements /config/save route. Saves what little configuration we actually use to config/main.cfg
=cut
sub config_save ($query) {
return $query->{tpsgi}->see_also('/login') unless $query->{user};
return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
my $conf = Trog::Config::get();
$conf->param( 'general.theme', $query->{theme} ) if defined $query->{theme};
$conf->param( 'general.data_model', $query->{data_model} ) if $query->{data_model};
$conf->param( 'security.allow_embeds_from', $query->{embeds} ) if $query->{embeds};
$conf->param( 'general.hostname', $query->{hostname} ) if $query->{hostname};
$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 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 grep { $_ 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 grep { $_ eq 'admin' } @{ $qq->{user_acls} };
my $query = clone($qq);
my $to = delete $query->{to};
#Copy this down since it will be deleted later
my $acls = $query->{acls};
$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", @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 grep { $_ 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 grep { $_ 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} );
}
=head2 _enrich_post($post, $query, $cache)
Resolve a post type's declared relations onto the post, and run its enrich sub
if it has one.
A type says what it depends on in its sidecar rather than in code here -- see
Trog::DataModule::relations_for. An entry naming a 'from' field resolves the
UUID in that field into the post it refers to; one without gets every post of
the target type, which is what an editor picker or a "show me all of these"
display wants.
$cache is a per-request memo of the per-type lookups. Without it a page of
invoices re-scans every entities post once per invoice.
=cut
sub _enrich_post ( $post, $query, $cache = {} ) {
return unless Ref::Util::is_hashref($post) && $post->{form};
my $relations = Trog::DataModule::relations_for( $post->{form} );
foreach my $as ( keys(%$relations) ) {
my $relation = $relations->{$as};
next unless Ref::Util::is_hashref($relation);
my ($target) = ( $relation->{form} // '' ) =~ m/^([A-Za-z0-9_-]+\.tx)$/;
next unless $target;
$cache->{$target} //= [ _post_helper( { form => $target }, [], $query->{user_acls} ) ];
# No 'from' means the relation is the whole set rather than one of them.
my $from = $relation->{from};
if ( !$from ) {
$post->{$as} = $cache->{$target};
next;
}
my $wanted = $post->{$from};
$post->{$as} = defined $wanted ? List::Util::first { $_->{id} eq $wanted } @{ $cache->{$target} } : undef;
}
_enrich_callback( $post, $query );
return;
}
# Anything a type needs computed rather than merely fetched. The sub is named
# in the sidecar, so validate it the same way a post's own callback field is --
# a sidecar naming an arbitrary sub is a privilege question, not a typo.
sub _enrich_callback ( $post, $query ) {
my $meta = Trog::DataModule::type_meta_for( $post->{form} );
my $sub = $meta->{'x-tcms-post-type'}{enrich};
return unless $sub && !ref $sub;
my ($modname) = $sub =~ m/^([\w:]+)::\w+$/;
if ( !$modname ) {
WARN("Post type '$post->{form}' declares a malformed enrich sub '$sub'");
return;
}
my $modpath = $modname;
$modpath =~ s{::}{/}g;
$modpath .= '.pm';
local $@;
eval { require $modpath; 1 } or do {
WARN("Post type '$post->{form}' declares enrich sub '$sub', but $modname will not load: $@");
return;
};
no strict 'refs';
if ( !defined &{$sub} ) {
WARN("Post type '$post->{form}' declares enrich sub '$sub', which does not exist");
return;
}
my %extra = &{$sub}( $post, $query );
use strict;
@$post{ keys(%extra) } = values(%extra);
return;
}
=head2 series
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( /\//, $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
my @posts = _post_helper( $query, ['series'], $query->{user_acls} );
# The series post carries its *children's* relations, so that an editor
# picker rendered on this page has something to populate from -- that is
# what $primary_post.entities is on an invoice series. Keyed on child_form
# rather than form: the series is a series.tx, its children are what
# declare the dependency.
if ( $posts[0] ) {
my $relations = Trog::DataModule::relations_for( $posts[0]{child_form} );
if (%$relations) {
# Resolve against a stand-in wearing the child's form, then copy
# only the relation keys back, so nothing else about the series
# post gets overwritten.
my $stand_in = { %{ $posts[0] }, form => $posts[0]{child_form} };
_enrich_post( $stand_in, $query );
@{ $posts[0] }{ keys(%$relations) } = @{$stand_in}{ keys(%$relations) };
}
}
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) {
push( @{ $query->{user_acls} }, 'public' );
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( /\//, $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;
push( @{ $query->{user_acls} }, 'public' );
$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);
}
=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( /\//, $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} };
push( @{ $query->{user_acls} }, 'public' );
push( @{ $query->{user_acls} }, 'unlisted' ) if $query->{id};
push( @{ $query->{user_acls} }, 'private' ) if $is_admin;
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 $id = delete $query->{id};
$query->{author} = $user->{user};
@posts = _post_helper( $query, $tags, $query->{user_acls} );
@posts = grep { $_->{id} ne $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 ? _themed_title( $query->{route} ) : $query->{route};
return _rss( $query, $ph, \@posts ) if $fmt eq 'rss';
#XXX Is used by the sitemap, maybe just fix there?
my @post_aliases = map { $_->{local_href} } _get_series();
# Allow themes to put in custom headers/footers on posts
my ( $header, $footer );
$header = Trog::Renderer->render(
template => 'headers/' . $query->{primary_post}{header},
data => { theme_dir => Trog::Themes::td(), %$query },
component => 1,
contenttype => 'text/html',
) if $query->{primary_post}{header};
return $header if ref $header eq 'ARRAY';
$footer = Trog::Renderer->render(
template => 'footers/' . $query->{primary_post}{footer},
data => { theme_dir => Trog::Themes::td(), %$query },
component => 1,
contenttype => 'text/html',
) if $query->{primary_post}{footer};
return $header if ref $footer eq 'ARRAY';
# 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
# Handle post style.
if ( $query->{style} ) {
undef $header;
undef $footer;
}
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 = $_;
!grep { $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};
my $picker = Trog::Component::EmojiPicker::render();
return $picker if ref $picker eq 'ARRAY';
# 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
#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 => scalar(@posts) == $limit,
older => $older,
newer => $newer,
sizes => [ 25, 50, 100 ],
rss => !$query->{id} && !$query->{older},
tiled => $tiled,
category => $ph,
subhead => $query->{subhead},
header => $header,
footer => $footer,
headers => $headers,
footers => $footers,
years => [ reverse( $oldest_year .. $now_year ) ],
months => [ 0 .. 11 ],
emoji_picker => $picker,
embed => $query->{embed},
nochrome => $query->{nochrome},
},
contenttype => 'text/html',
component => 1,
);
# Something exploded
return $content if ref $content eq "ARRAY";
return $content if $direct;
return Trog::Routes::HTML::index( $query, $content, $styles );
}
sub _themed_title ($path) {
return $path unless %Theme::paths;
return $Theme::paths{$path} ? $Theme::paths{$path} : $path;
}
=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 $meta = Trog::DataModule::type_meta_for( $series->{child_form} );
my $source = $meta->{'x-tcms-datasource'};
return @$posts unless $source && !ref $source;
# Named in a sidecar, so check it rather than requiring whatever we were
# told to. The namespace restriction is the point: a sidecar cannot make
# us load an arbitrary module.
if ( $source !~ m/^Trog::DataSource::\w+$/ ) {
WARN("Post type '$series->{child_form}' names a datasource '$source' which isn't one");
return @$posts;
}
my $modpath = $source;
$modpath =~ s{::}{/}g;
$modpath .= '.pm';
local $@;
eval { require $modpath; 1 } or do {
WARN("Datasource '$source' will not load: $@");
return @$posts;
};
no strict 'refs';
my $sub = "${source}::posts";
if ( !defined &{$sub} ) {
WARN("Datasource '$source' has no posts() to call");
return @$posts;
}
my @synthesized = eval { &{$sub}( $series, $query ) };
use strict;
if ($@) {
my $err = "$@";
$err =~ s/\n.*//s;
WARN("Datasource '$source' failed: $err");
return @$posts;
}
return @synthesized;
}
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 { !defined $routes{$_}->{captures} && !$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 );
}
sub _rss ( $query, $subtitle, $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,
);
}
sub _post2rss ( $rss, $url, $post ) {
$rss->add_item(
title => $post->{title},
permaLink => $url,
link => $url,
enclosure => { url => $url, type => "text/html" },
description => "{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
);
}
=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 grep { $_ 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";
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 ($query) {
return Trog::Routes::HTML::index(
{
title => "Your request has been processed",
theme_dir => Trog::Themes::td(),
},
"Your request has been processed.
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 grep { $_ 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.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 grep { $_ 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.
our @wizard_checkboxes = ( qw{wrapper inc_post_title inc_post_tags inc_title_input}, @wizard_include_order, 'overwrite' );
our %wizard_checked_by_default = map { $_ => 1 } qw{wrapper inc_post_title inc_post_tags inc_title_input inc_preview inc_visibility inc_acls inc_tags inc_aliases};
# Which HTML input the wizard emits, and what that field is in the sidecar's
# OpenAPIv3 schema. No 'file': _process() in Trog::DataModule only knows how to
# turn the four hardcoded upload fields into hrefs, so a custom file field would
# store an HTTP::Body::OctetStream that nothing ever picks up. Point folks at
# the attachment uploader instead.
our %wizard_field_types = (
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};
=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 grep { $_ 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 grep { $_ 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" );
}
# 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.
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 post_wizard
Implements /admin/wyzzerdd. Admin only.
The post type wizard: lists the post types which currently exist and offers a
form for building a new one. See post_wizard_save() for what happens when that
form comes back.
Re-rendered by post_wizard_save() on both success and failure, so it keeps the
submitted values and checkbox states rather than making the admin retype
everything after a rejected submission.
=cut
sub post_wizard ($query) {
return $query->{tpsgi}->see_also('/login') unless $query->{user};
return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
$query->{failure} //= -1;
# Get the existing post types
my $forms = Trog::Themes::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(),
checked => \%checked,
name => _wizard_scalar( $query->{name} ),
title_placeholder => _wizard_scalar( $query->{title_placeholder} ),
body_form => _wizard_scalar( $query->{body_form} ),
display => _wizard_scalar( $query->{display} ),
failure => $query->{failure},
message => $query->{message} // '',
to => $query->{to} // '',
},
undef,
['post.css'],
);
}
=head2 post_wizard_save
Implements POST /admin/wyzzerdd/save.
Writes a new post type template into whichever forms directory is currently in
use, along with a JSON sidecar naming its custom fields so that
Trog::DataModule::schema_for will merge it over the base post schema, so the
type's own fields survive validation at save time.
=cut
sub post_wizard_save ($query) {
return $query->{tpsgi}->see_also('/login') unless $query->{user};
return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
# Anchored capture rather than a substitution, so anything containing a '/'
# or a '..' simply fails to match instead of being silently scrubbed into
# something that still escapes the directory.
my ($name) = _wizard_scalar( $query->{name} ) =~ m/^([A-Za-z0-9_-]+)$/;
return _wizard_fail( $query, "Post type names may only contain letters, numbers, '-' and '_'." ) unless $name;
# Whichever forms dir is in use: the theme's if it has one, the stock one
# otherwise. Never mkdir it -- silently conjuring a forms/ dir inside a
# theme is not something an admin asked for by pressing this button.
my $dir = Trog::Themes::forms_dir();
return _wizard_fail( $query, "Forms directory '$dir' does not exist, or is not writable." ) unless -d $dir && -w $dir;
my $tx_file = "$dir/$name.tx";
my $json_file = "$dir/$name.json";
my $overwriting = -e $tx_file;
return _wizard_fail( $query, "Post type '$name.tx' already exists. Tick 'Overwrite' if you meant to replace it." )
if $overwriting && !$query->{overwrite};
my $fields = _wizard_fields($query);
my @includes = grep { $query->{$_} } @wizard_include_order;
my $body_form = _wizard_scalar( $query->{body_form} ) eq 'form_multi.tx' ? 'form_multi.tx' : 'form_common.tx';
my $spec = _wizard_sidecar( $name, $fields, \@includes, $body_form );
local $@;
eval {
Path::Tiny::path($tx_file)->spew_utf8( _wizard_template( $query, $fields, \@includes, $body_form ) );
Path::Tiny::path($json_file)->spew_utf8( JSON::MaybeXS->new( pretty => 1, canonical => 1 )->encode($spec) );
1;
} or return _wizard_fail( $query, "Failed to write post type '$name': $@" );
INFO("Post type '$name' written to $tx_file by $query->{user}");
# Nothing else is needed to publish a new type: themed_templates_in_dir()
# re-reads
# the directory every call, and Xslate resolves includes lazily, so both the
# wizard's own list and the series child_form dropdown pick it up on the
# next request without a restart. Overwriting an *existing* type is another
# matter -- that changes how already-rendered anonymous pages should look.
if ($overwriting) {
$query->{tpsgi}->add_post_close_callback(
sub {
$query->{tpsgi}->invalidate_renders('html');
}
);
}
return post_wizard(
{
%$query,
wizard_submitted => 1,
failure => 0,
message => "Created post type '$name.tx'.",
to => '/admin/wyzzerdd',
}
);
}
# Repeated params arrive as arrayrefs; anywhere we want one string, insist on one string.
sub _wizard_scalar ( $value = '' ) {
return '' if !defined $value || ref $value;
return $value;
}
sub _wizard_fail ( $query, $message ) {
WARN($message);
return post_wizard(
{
%$query,
wizard_submitted => 1,
failure => 1,
message => $message,
}
);
}
=head2 _kolon_safe
Make a submitted string safe to splice into a generated Kolon template.
Newlines have to go, as a ':' at the start of a line is a Kolon directive, and
the angle brackets have to go so that '<:' can never be reassembled.
=cut
sub _kolon_safe ( $string = '' ) {
$string = _wizard_scalar($string);
$string =~ s/[\r\n]+/ /g;
$string =~ s/&/&/g;
$string =~ s/</g;
$string =~ s/>/>/g;
$string =~ s/"/"/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 ( @fields, %seen );
foreach my $index ( 0 .. $#$names ) {
my ($fname) = lc( _wizard_scalar( $names->[$index] ) ) =~ m/^([a-z][a-z0-9_]{0,31})$/;
# Blank and bogus rows just get dropped.
next unless $fname;
next if $seen{$fname}++;
# Never let a custom field shadow a core post attribute.
next if exists $Trog::DataModule::post_schema{properties}{$fname};
next if grep { $fname eq $_ } @wizard_reserved;
my $type = _wizard_scalar( $types->[$index] );
$type = 'text' unless $wizard_field_types{$type};
# A relation is only a relation if it names a target type that looks
# like one; anything else falls back to being a plain text field.
my ($rform) = _wizard_scalar( $rforms->[$index] ) =~ m/^([A-Za-z0-9_-]+\.tx)$/;
my $rmode = _wizard_scalar( $rmodes->[$index] ) eq 'all' ? 'all' : 'one';
$type = 'text' if $type eq 'relation' && !$rform;
push(
@fields,
{
name => $fname,
type => $type,
label => _kolon_safe( $labels->[$index] ) || ucfirst($fname),
placeholder => _kolon_safe( $phs->[$index] ),
required => _wizard_scalar( $reqs->[$index] ) ? 1 : 0,
relation_form => $rform,
relation_mode => $rmode,
}
);
}
return \@fields;
}
=head2 _wizard_sidecar
Turn the wizard's field list into the post type's JSON sidecar: an OpenAPIv3
object schema describing what this type ingests, with the wizard's own UI
metadata hung off x- extension keys so there's only one file to keep in sync.
Trog::DataModule::schema_for() merges this over the base post schema.
=cut
sub _wizard_sidecar ( $name, $fields, $includes, $body_form ) {
my %properties;
my @required;
my %relations;
foreach my $field (@$fields) {
# A relation pulling in every post of its target type isn't a field the
# post stores at all -- it is purely something injected at render, so
# it gets a relations entry and no property.
if ( $field->{type} eq 'relation' && $field->{relation_mode} eq 'all' ) {
$relations{ $field->{name} } = { form => $field->{relation_form} };
next;
}
my $property = { %{ $wizard_field_types{ $field->{type} } } };
$property->{'x-tcms-input'} = $field->{type};
$property->{'x-tcms-label'} = $field->{label};
$property->{'x-tcms-placeholder'} = $field->{placeholder} if length $field->{placeholder};
if ( $field->{type} eq 'relation' ) {
$property->{'x-tcms-relation-form'} = $field->{relation_form};
# The stored field holds a UUID; the resolved post lands beside it.
$relations{"$field->{name}_post"} = { form => $field->{relation_form}, from => $field->{name} };
}
$properties{ $field->{name} } = $property;
push( @required, $field->{name} ) if $field->{required};
}
my %spec = (
'x-tcms-post-type' => {
name => $name,
generated => JSON::MaybeXS::true(),
generator => 'Trog::Routes::HTML::post_wizard_save',
body_form => $body_form,
includes => [ map { $wizard_includes{$_} } @$includes ],
},
type => 'object',
properties => \%properties,
);
$spec{required} = \@required if @required;
$spec{'x-tcms-relations'} = \%relations if %relations;
return \%spec;
}
sub _wizard_field_html ($field) {
my ( $n, $t, $l, $p ) = @$field{qw{name type label placeholder}};
my $required = $field->{required} ? 'required ' : '';
if ( $t eq 'relation' ) {
# 'all' relations aren't stored, so there is nothing to edit.
return '' if $field->{relation_mode} eq 'all';
# Left empty on purpose: post_relations.js fills it from
# /api/posts_of_form, so the picker can't go stale against the
# generated template.
return qq| $l
\n|;
}
return qq| $l
\n|
if $t eq 'textarea';
return qq|
\n|
if $t eq 'checkbox';
return qq| $l
\n|;
}
=head2 _wizard_template
Assemble the actual .tx file, following the shape of the hand-written forms:
a display half guarded by !$post.addpost, and an edit half guarded by $can_edit.
=cut
sub _wizard_template ( $query, $fields, $includes, $body_form ) {
my $placeholder = _kolon_safe( $query->{title_placeholder} ) || 'Iowa Man Destroys Moon';
# NOT escaped, on purpose. Letting an admin write template code is the
# entire point of the wizard, and it is no more privileged than the data
# field of any post, which already gets run through render_it(). Both
# sides of this route are behind the admin ACL.
my $display = _wizard_scalar( $query->{display} );
my $out = "\n";
$out .= qq|