package Trog::Routes::HTML;
use v5.36;
use re '/aa';
no warnings qw{once};
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} = "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 _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;
opendir( my $dh, $dir ) or next;
$found{"Trog::DataSource::$_"} = 1 foreach map { s/\.pm$//r } grep { /\.pm$/ && -f "$dir/$_" } readdir($dh);
closedir $dh;
}
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 constant. 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;
my $modpath = $module;
$modpath =~ s{::}{/}g;
$modpath .= '.pm';
local $@;
eval { require $modpath; 1 } or do {
WARN("Datasource '$module' will not load: $@");
return 1;
};
return 1 unless $module->can('EDITABLE');
return $module->EDITABLE ? 1 : 0;
}
=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} };
# posts() widens user_acls to what a viewer can actually see, but
# that happens after this -- so resolving here against the raw list
# means a logged out visitor resolves every relation against no
# acls at all, and finds nothing however public the target is.
my @acls = ( @{ $query->{user_acls} }, 'public' );
push( @acls, 'private' ) if $is_admin;
_enrich_post( $stand_in, { %$query, user_acls => \@acls } );
@{ $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
# 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 => 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 _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. Recurses, because a post's relations are
posts too and carry their own private fields.
=cut
sub _redact_private ( $post, $seen = {} ) {
return unless Ref::Util::is_hashref($post);
# Relations can point back at what pulled them in.
return if $seen->{$post}++;
if ( $post->{form} ) {
delete $post->{$_} foreach @{ Trog::DataModule::private_fields_for( $post->{form} ) };
}
foreach my $value ( values(%$post) ) {
if ( Ref::Util::is_hashref($value) ) { _redact_private( $value, $seen ) }
elsif ( Ref::Util::is_arrayref($value) ) { _redact_private( $_, $seen ) foreach @$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 $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.
# 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 = $_;
!grep { $include eq $_ } @wizard_mandatory
} @wizard_include_order;
our @wizard_checkboxes = ( qw{wrapper inc_post_title inc_post_tags}, @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};
=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(),
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'],
);
}
=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};
# 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 && !grep { $_ 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 );
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}");
# 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;
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 ( @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,
private => _wizard_scalar( $private->[$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 = '' ) {
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};
# 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};
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;
$spec{'x-tcms-datasource'} = $datasource if $datasource;
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, $datasource = '' ) {
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";
# 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|
\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|
\n|;
$out .= qq| : include "edit_head.tx";\n|;
$out .= qq| \n|;
$out .= qq| : include "edit_foot.tx";\n|;
$out .= qq|
\n|;
$out .= qq| : }\n|;
$out .= qq|\n| if $query->{wrapper};
return $out;
}
# basically a file rewrite rule for themes
=head2 icon
Implements the /img/icon/* routes.
Serves a themed icon, falling back to the stock one. A rewrite rule with extra
steps, essentially, so that themes can replace individual icons.
=cut
sub icon ($query) {
my $path = $query->{route};
my $tpath = Trog::Themes::themed("img/icon/$path");
return $query->{tpsgi}->serve( $path, $tpath, $query->{start}, $query->{streaming}, $query->{ranges}, $query->{last_fetched}, $query->{deflate} );
}
=head2 totp_qr
Implements the /totp/* routes.
Serves the QR code generated when a user enables TOTP. These live outside
www/, so they go out through serve() rather than the static file handler --
handing someone else's enrolment QR out to the world would be handing them the
shared secret.
=cut
sub totp_qr ($query) {
my $fname = basename($query->{route});
# For authenticated content, we have to now do a serve().
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. The header
and footer are rendered here and passed in as strings because the output is
XSL rather than HTML, so an include directive isn't available.
=cut
sub rss_style ($query) {
$query->{port} = ":$query->{port}" if $query->{port};
$query->{title} = qq{};
$query->{no_doctype} = 1;
# Due to this being html rather than XML, we can't use an include directive.
$query->{header} = Trog::Renderer->render( template => 'header.tx', data => $query, contenttype => 'text/html', component => 1 );
$query->{footer} = Trog::Renderer->render( template => 'footer.tx', data => $query, contenttype => 'text/html', component => 1 );
return Trog::Renderer->render(
template => 'rss-style.tx',
contenttype => 'text/xsl',
data => $query,
code => 200,
);
}
sub _build_themed_styles ($styles) {
my @styles = map { ( Trog::Themes::themed_style("$_") ) } @{ Trog::Utils::coerce_array($styles) };
return \@styles;
}
sub _build_themed_scripts ($scripts) {
my @scripts = map { Trog::Themes::themed_script("$_") } @{ Trog::Utils::coerce_array($scripts) };
return \@scripts;
}
=head2 finish_render($template, $vars, %headers)
Render a full page, as opposed to a component.
Fills in the defaults every page needs (lang, title, status code, content type,
cache control), resolves stylesheet and script names through the theme, makes
their paths absolute, renders the header and footer, and hands the lot to
Trog::Renderer.
Just about everything in this module ends up here; index() is the usual way in.
=cut
sub finish_render ( $template, $vars, %headers ) {
#XXX default vars that need to be pulled from config
$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} ) } ];
$vars->{scripts} = [ map { s/^www\///; $_ } @{ _build_themed_scripts( $vars->{scripts} ) } ];
# Add in avatars.css, it's special
push( @{ $vars->{stylesheets} }, "/styles/avatars.css" );
# Absolute-ize the paths for scripts & stylesheets
@{ $vars->{stylesheets} } = map { CORE::index( $_, '/' ) == 0 ? $_ : "/$_" } @{ $vars->{stylesheets} };
@{ $vars->{print_styles} } = map { CORE::index( $_, '/' ) == 0 ? $_ : "/$_" } @{ $vars->{print_styles} };
@{ $vars->{scripts} } = map { CORE::index( $_, '/' ) == 0 ? $_ : "/$_" } @{ $vars->{scripts} };
# 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};
$vars->{header} = Trog::Renderer->render( template => 'header.tx', data => $vars, contenttype => 'text/html', component => 1 );
$vars->{footer} = Trog::Renderer->render( template => 'footer.tx', data => $vars, contenttype => 'text/html', component => 1 );
return Trog::Renderer->render( template => $template, data => $vars, contenttype => 'text/html', code => $vars->{code} );
}
1;