tCMS/lib/TCMS.pm

package TCMS;

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

use Carp  qw{confess};
use Clone qw{clone};

use CGI::Cookie ();
use List::Util  ();
use Sub::Util   ();
use URI();

#Grab our custom routes
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;

# Loaded here rather than where it is used, so that the vault key comes out of
# the environment once, in the parent, before there is a worker to fork -- see
# Trog::Vault.
use Trog::Vault;    ## no critic (ProhibitUnusedImports) -- loaded for what it does at load time, as above
use Trog::Data;
use Trog::Themes;
use Trog::Bundle;

# The data of a route names its callback, and the code of a route holds a reference to it.
my sub _callback_name ($callback) {
    return ref $callback ? Sub::Util::subname($callback) : $callback // '';
}

#XXX Return a clone of the routing table ref, because code modifies it later
my 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();

    # OpenAPI has no escape for a brace, so such a path would be a template.
    foreach my $href ( grep { m/[{}]/ } keys(%roots) ) {
        WARN("Not routing $href: a path with a brace in it cannot be a route");
        delete $roots{$href};
    }

    # One template routes every post at the href that a post gets by default,
    # because tPSGI checks a route at a time, and a site has thousands of posts.
    my @posts = grep { m{\A/posts/[^/]+\z} && _callback_name( $roots{$_}{callback} ) eq 'Trog::Routes::HTML::posts' } keys(%roots);
    delete @roots{@posts};
    $roots{'/posts/{id}'} = { method => 'GET', callback => 'Trog::Routes::HTML::posts' };

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

    # A page of posts gets the scripts of one, unless its route names its own.
    foreach my $path ( keys(%routes) ) {
        my $name = _callback_name( $routes{$path}{callback} );
        next if exists $routes{$path}{scripts} || !List::Util::any { $_ eq $name } @Trog::Routes::HTML::post_page_callbacks;
        $routes{$path} = { %Trog::Routes::HTML::post_page_scripts, %{ $routes{$path} } };
    }

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

# Troglodyne philosophy - simple as possible

=head2 build_routes() = HASH

The OpenAPI 3 document that tPSGI routes by, made from the routing table that
_routes() returns.  Each route becomes the operation of its method, under its
path.  The operation's x-tpsgi-callback is the route's callback, wrapped in what
every tCMS request needs.  C<data> becomes x-tpsgi-data, and C<auth>,
C<nocache>, C<noindex>, C<nomap>, C<robot_name> and C<totp_exempt> become
x-tcms-auth and so on, which the callback finds in C<< $query->{dispatcher} >>.
C<parameters> are OpenAPI parameter objects, and each variable of a template
that they leave out is a required string.  A route with no method is a GET.
Every route links the scripts of @Theme::scripts before its own C<scripts>.

A route that does not declare its parameters takes the query or the form that
%Trog::Routes::HTML::inputs names for its callback, less what its C<data> fixes and
its path holds.  Every GET also takes the parameters of a campaign, utm_source
and the rest.  The wrapper gives the callback the input of the request in
C<< $query->{input} >>, and sets C<to> beside it, as a path on this site.

The C<default> route is not a path.  The wrapper calls it when there is no
F<config/setup>.

=cut

my @tcms_keys = qw{auth nocache noindex nomap robot_name totp_exempt scripts authenticated_scripts};

# The parameters of a campaign, which any page can be linked with.
my @urchin = qw{utm_source utm_medium utm_campaign utm_term utm_content};

# How a browser sends a form.
my @form_types = qw{application/x-www-form-urlencoded multipart/form-data};

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

    # The theme's scripts go on every page, before the page's own.  A copy of
    # each route, since a route and its /secure copy share one hash.
    my @theme_scripts = do { no warnings 'once'; @Theme::scripts };
    if (@theme_scripts) {
        $routes{$_} = { %{ $routes{$_} }, scripts => [ @theme_scripts, @{ $routes{$_}{scripts} // [] } ] } for keys(%routes);
    }

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

    my %paths;
    foreach my $k ( sort grep { $_ ne 'default' } keys(%routes) ) {
        my $v = $routes{$k};

        # The bundles that this route's page can link, for a reader and for a
        # reader who is logged in.
        my @scripts = @{ $v->{scripts} // [] };
        Trog::Bundle::declare( \@scripts, [ @scripts, @{ $v->{authenticated_scripts} // [] } ] );

        my $method = lc( $v->{method} // 'GET' );

        # FlatFile and the tag index name the callback rather than hold it.
        my $callback = $v->{callback};
        next unless $callback;
        my $callback_name = ref $callback ? Sub::Util::subname($callback) : $callback;
        $callback = \&{$callback} unless ref $callback;

        #XXX For now we will discard the tPSGI object.  We might want it later.
        my $cb_wrap = sub {    ## no critic (ProhibitSingleUseLexicalSubs) -- 71 lines, which would overcomplicate build_routes()
            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', $tpsgi->{loggers} );

            # 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

            my $input = $query->{input} //= {};

            # Set the urchin parameters if necessary.
            %$Trog::Log::DBI::urchin = map { $_ => $input->{$_} } @urchin;

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

            $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;

            # Only ever a path on this site, so that no link can send a visitor to
            # another one.  One slash, because a browser reads two as a host.
            $query->{to} = ( URI->new( $input->{to} )->path() || '/' ) =~ s{\A/+}{/}r if $input->{to};

            # Now that we have firmed up the actual routing, let's validate.
            return $tpsgi->forbidden($query) if exists $query->{dispatcher}{'x-tcms-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');
            }

            return $callback->($query);
        };

        my @parameters = @{ $v->{parameters} // [] };
        foreach my $variable ( $k =~ m/\{([^{}]+)\}/g ) {
            next if List::Util::any { $_->{in} eq 'path' && $_->{name} eq $variable } @parameters;
            push( @parameters, { name => $variable, in => 'path', required => true, schema => { type => 'string' } } );
        }

        # What the callback takes from the request, less what the route fixes in
        # its data or holds in its path.  A route that declares its parameters
        # declares all of its query.
        my $inputs = { %{ $Trog::Routes::HTML::inputs{$callback_name} // {} } };
        $_ = $_->() for grep { ref eq 'CODE' } @$inputs{qw{query body}};
        my %taken = map { $_ => 1 } keys( %{ $v->{data} // {} } ), map { $_->{name} =~ s/[+]\z//r } @parameters;
        my %query = ( ( $v->{parameters} ? () : %{ $inputs->{query} // {} } ), ( $method eq 'get' ? map { $_ => { type => 'string' } } @urchin : () ) );
        push( @parameters, map { { name => $_, in => 'query', schema => $query{$_} } } grep { !$taken{$_} } sort keys(%query) ) if $method eq 'get';

        my $body = $inputs->{body};
        my %form = (
            type       => 'object',
            properties => { map { $_ => $body->{$_} } grep { !$taken{$_} } keys( %{ $body // {} } ) },
            ( $inputs->{open} ? ( additionalProperties => true ) : () ),
        );
        my $request_body = $method eq 'post' && ( $body || $inputs->{open} ) ? { content => { map { $_ => { schema => \%form } } @form_types } } : undef;

        $paths{$k}{$method} = {
            'x-tpsgi-callback' => $cb_wrap,
            ( $v->{data} ? ( 'x-tpsgi-data' => $v->{data} ) : () ),
            ( map { ( "x-tcms-$_" => $v->{$_} ) } grep { exists $v->{$_} } @tcms_keys ),
            ( @parameters   ? ( parameters  => \@parameters )  : () ),
            ( $request_body ? ( requestBody => $request_body ) : () ),
            responses => { default => { description => 'The page, or an error page' } },
        };
    }

    return (
        openapi => '3.0.3',
        info    => { title => 'tCMS', version => '1' },
        paths   => \%paths,
    );
}

=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 enrollment 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 enrollment 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.  $dispatcher is the operation that
build_routes() made, so it holds them as x-tcms-auth and x-tcms-totp_exempt.

=cut

sub needs_enrolment ( $user, $dispatcher ) {
    return 0 unless $user;
    return 0 if !$dispatcher || !$dispatcher->{'x-tcms-auth'} || $dispatcher->{'x-tcms-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";

    # What the error pages read: 404.tx the path that was not found, and
    # 500.tx the message that tPSGI sets when a route dies.
    $query->{path} = $query->{fullpath} // $query->{route};
    $query->{message} //= undef;
    return Trog::Routes::HTML::index($query);
}

our %openapi = build_routes();
our %aliases = aliases();

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();

    # A template's variables can be anything, which robots.txt spells as *.
    state @banned = map {
        my $robot_name = $routes->{$_}{robot_name} // $_;
        $robot_name =~ s/\{[^{}]*\}/*/g;
        $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;