tCMS/lib/TCMS.pm

package TCMS;

use v5.36;
use re '/aa';

use Carp         qw{confess};
use Clone        qw{clone};
use Date::Format qw{strftime};

use Sys::Hostname();
use HTTP::Body   ();
use URL::Encode  ();
use Text::Xslate ();
use DateTime::Format::HTTP();
use CGI::Cookie ();
use File::Basename();
use Time::HiRes qw{gettimeofday tv_interval};
use List::Util;
use URI();
use Ref::Util qw{is_coderef is_hashref is_arrayref};

#Grab our custom routes
use FindBin;
use lib "$FindBin::Bin/../lib";
use FindBin::libs;

use Trog::Routes::HTML;
use Trog::Routes::JSON;

use Trog::Log qw{:all};
use Trog::Log::DBI;

use Trog::Auth;
use Trog::Config;
use Trog::Data;
use Trog::Themes;

# Troglodyne philosophy - simple as possible

my $cur_query = {};

# Build routes
sub build_routes {
    my $conf   = Trog::Config::get();
    my $data   = Trog::Data->new($conf);
    my %routes = %{ _routes($data) };

    my $default_route = $routes{default}{callback};

    # Transform 'method' / 'callback' to new scheme
    my %routes_adj;
    foreach my $k ( keys(%routes) ) {
        my $v = $routes{$k};

        # Some routes are just pointers to other routes.
        # In this case they might have already been transformed and need to be skipped.
        if ( exists $v->{callbacks} ) {
            $routes_adj{$k} = $v;
            next;
        }

        my %cb;
        my $method   = $v->{method};
        my $callback = delete $v->{callback};

        #XXX For now we will discard the tPSGI object.  We might want it later.
        my $cb_wrap = sub {
            my ( $tpsgi, $query ) = @_;

            confess "Cannot determine directory for logs!" unless $tpsgi->{log_dir};

            # Make sure the tCMS logs live in the same dir as the tpsgi logs.
            log_init( "$tpsgi->{log_dir}/tpsgi.log", $tpsgi->{verbose} ? 'debug' : 'info' );

            # Let's open up our default route if needed before we bother thinking any harder
            return $default_route->($query) unless -f "config/setup";    ## no critic (ProhibitFiletest_f) -- a flag file, only ever touched

            # Set the urchin parameters if necessary.
            %$Trog::Log::DBI::urchin = map { $_ => delete $query->{$_} } qw{utm_source utm_medium utm_campaign utm_term utm_content};

            # Set the IP of the request so we can fail2ban
            $Trog::Log::ip = $query->{ip};

            # Set the referer & ua to go into DB logs, but not logs in general.
            # The referer/ua largely has no importance beyond being a proto bug report for log messages.
            $Trog::Log::DBI::referer = $query->{referer};
            $Trog::Log::DBI::ua      = $query->{ua};

            # Figure out if we have a logged in user, so we can serve them user-specific files
            my $cookies = {};
            $cookies = CGI::Cookie->parse( $query->{cookies} ) if $query->{cookies};

            my $active_user = '';
            $Trog::Log::user = 'nobody';
            if ( exists $cookies->{tcmslogin} ) {
                $active_user     = Trog::Auth::session2user( $cookies->{tcmslogin}->value );
                $Trog::Log::user = $active_user if $active_user;
            }

            # Make sure TPSGI can log the user
            $tpsgi->{user} = $active_user;

            # Enrich the query with tcms specific foo
            $query->{user_acls} = [];
            $query->{user_acls} = Trog::Auth::acls4user($active_user) // [] if $active_user;

            # Grab the list of ACLs we want to add to a post, if any.
            $query->{acls} = [ $query->{acls} ] if ( $query->{acls} && ref $query->{acls} ne 'ARRAY' );

            # Filter out passed ACLs which are naughty
            my $is_admin = grep { $_ eq 'admin' } @{ $query->{user_acls} };
            @{ $query->{acls} } = grep { $_ ne 'admin' } @{ $query->{acls} } unless $is_admin;

            $query->{user}         = $active_user;
            $query->{body}         = '';
            $query->{social_meta}  = 1;
            $query->{primary_post} = {};
            $query->{nocache}      = $v->{nocache};

            # Some routes may just need to do serve()
            $query->{tpsgi} = $tpsgi;

            # Redirecting somewhere naughty not allow
            $query->{to} = URI->new( $query->{to} // '' )->path() || $query->{to} if $query->{to};

            # Now that we have firmed up the actual routing, let's validate.
            return $tpsgi->forbidden($query) if exists $query->{dispatcher}{auth} && !$active_user;

            if ( needs_enrolment( $active_user, $query->{dispatcher} ) ) {
                INFO("$active_user has no TOTP enrolment; sending them to /totp");
                return $tpsgi->see_also('/totp');
            }

            no strict 'refs';
            $callback->($query);
            use strict;
        };

        #XXX todo support different callbacks per requested content-type
        $cb{'*'} = $cb_wrap if $callback;

        $v->{callbacks} = \%cb;
        $routes_adj{$k} = $v;
    }

    return [%routes_adj];
}

=head2 needs_enrolment($user, $dispatcher) = BOOL

Whether this request should be turned around and sent to /totp.

Two factors or nothing.  A login is what gets you to the enrolment page -- the QR
is the shared secret, so it cannot be handed to whoever asks for it -- which
leaves a window where somebody is logged in and has no second factor yet.  This
is what makes that window one page wide: every route a login can reach, and no
route a logged out visitor can, is refused until they have enrolled.

The enrolment page and the QR on it say so themselves, with totp_exempt, because
the exemption belongs next to the route rather than in a list over here that the
routing table knows nothing about.

=cut

sub needs_enrolment ( $user, $dispatcher ) {
    return 0 unless $user;
    return 0 unless $dispatcher && $dispatcher->{auth} && !$dispatcher->{totp_exempt};
    return Trog::Auth::has_totp($user) ? 0 : 1;
}

# Override the generic error handler to look spiffy
sub generic_route ( $rname, $code, $title, $query ) {
    $query->{code} = $code;
    $query->{route} //= $rname;
    $query->{title}    = $title;
    $query->{template} = "$rname.tx";
    return Trog::Routes::HTML::index($query);
}

our @routes  = @{ build_routes() };
our %aliases = aliases();

#XXX Return a clone of the routing table ref, because code modifies it later
sub _routes ( $data = {} ) {
    state %routes;
    return clone( \%routes ) if %routes;

    my $conf = Trog::Config::get();
    $data = Trog::Data->new($conf) unless $data;

    # Routes in general are going to override earlier, more default ones.
    # XXX this is probably bad in the case of the specific content-typed routes, they should be mutex
    my %roots = $data->routes();

    # Setup the /secure/... versions for logged in users, except for already secured routes.
    foreach my $route ( keys(%roots) ) {
        next if index( $route, '/secure/' ) == 0;
        $roots{"/secure$route"} = $roots{$route};
    }

    # It is the responsibility of theme authors to setup /secure routes (other than index)
    my %themed = Trog::Themes::routes();

    %routes                                      = %Trog::Routes::HTML::routes;
    @routes{ keys(%Trog::Routes::JSON::routes) } = values(%Trog::Routes::JSON::routes);
    @routes{ keys(%roots) }                      = values(%roots);
    @routes{ keys(%themed) }                     = values(%themed) if %themed;

    # Add in global routes, here because they *must* know about all other routes
    # Also, nobody should ever override these.
    $routes{'/robots.txt'} = {
        method   => 'GET',
        callback => \&robots,
    };

    # Special 'am I authenticated' route for nginx
    $routes{'/authenticated'} = {
        method   => 'GET',
        nocache  => 1,
        noindex  => 1,
        callback => sub {
            my ($query) = @_;
            return $query->{tpsgi}->ok($query) if $query->{user};
            return $query->{tpsgi}->forbidden($query);
        },
    };

    # Heartbeat route
    $routes{'/status'} = {
        method   => 'GET',
        nocache  => 1,
        noindex  => 1,
        callback => sub {
            my ($query) = @_;
            return $query->{tpsgi}->ok($query);
        },
    };

    # The Various aliases for directory indices
    foreach my $index (qw{ / /index.html /index.htm}) {
        $routes{$index}          = $routes{'/index'} unless exists $routes{$index};
        $routes{"/secure$index"} = $routes{'/index'} unless exists $routes{"/secure$index"};
    }

    return clone( \%routes );
}

sub aliases {
    my $conf = Trog::Config::get();
    my $data = Trog::Data->new($conf);
    return $data->aliases();
}

=head2 robots

Return an appropriate robots.txt

This is a "special" route as it needs to know about all the routes in order to disallow noindex=1 routes.

=cut

# TODO anytime that the routing table changes, we need to invalidate the cache.
sub robots ($query) {
    state $etag = "robots-" . time();
    my $routes = _routes();

    # If there's a 'capture' route, we need to format it correctly.
    state @banned = map { exists $routes->{$_}{robot_name} ? $routes->{$_}{robot_name} : $_ } grep { $routes->{$_}{noindex} } sort keys(%$routes);

    return Trog::Renderer->render(
        contenttype => 'text/plain',
        template    => 'robots.tx',
        data        => {
            etag   => $etag,
            banned => \@banned,
            %$query,
        },
        code => 200,
    );
}

1;