#!/usr/bin/perl
#
# DW::Routing
#
# Module to allow calling non-BML controller/views.
#
# Authors:
#      Andrea Nall <anall@andreanall.com>
#      Mark Smith <mark@dreamwidth.org>
#
# Copyright (c) 2009-2013 by Dreamwidth Studios, LLC.
#
# This program is free software; you may redistribute it and/or modify it under
# the same terms as Perl itself.  For a copy of the license, please reference
# 'perldoc perlartistic' or 'perldoc perlgpl'.
#

package DW::Routing;
use strict;

use LJ::ModuleLoader;
use DW::Template;
use LJ::JSON;
use DW::Request;
use DW::Routing::CallInfo;
use Carp qw/croak/;

# IMPORTANT!
#
# If we change the internal representation here, the code in
# bin/dev/lookup-routing must also be updated.
#
# Thank you.
#
our %string_choices;
our %regex_choices = (
    app  => [],
    user => [],
    api  => []
);
our %api_endpoints;         # ver => { string => hash }
our %api_rest_endpoints;    # ver => { string => hash }

our $T_TESTING_ERRORS;

my $default_content_types = {
    atom  => 'application/atom+xml; charset=utf-8',
    html  => 'text/html; charset=utf-8',
    js    => 'application/javascript; charset=utf-8',
    json  => 'application/json; charset=utf-8',
    plain => 'text/plain; charset=utf-8',
    png   => 'image/png',
};

LJ::ModuleLoader->require_subclasses('DW::Controller')
    unless $DW::Routing::DONT_LOAD;    # for testing

=head1 NAME

DW::Routing - Module to allow calling non-BML controller/views.

=head1 Page Call API

=head2 C<< $class->call( $r, %opts ) >>

Valid options:

=over

=item uri - explicitly override the uri
=item role - explicitly define the role
=item username - define the username, implies username role

=back

This method should be directly returned by the caller if defined.

=cut

sub call {
    my $class     = shift;
    my $call_opts = $class->get_call_opts(@_);

    return $class->call_hash($call_opts) if defined $call_opts;
    return undef;
}

=head2 C<< $class->get_call_opts( $r, %opts ) >>

Valid options:

=over

=item uri - explicitly override the uri
=item role - explicitly define the role
=item username - define the username, implies username role

=back

Returns a call_opts hash, or undefined.

=cut

sub get_call_opts {
    my ( $class, %opts ) = @_;
    my $r = DW::Request->get;

    my $uri    = $opts{uri} || $r->uri;
    my $format = undef;
    ( $uri, $format ) = ( $1, $2 )
        if $uri =~ m/^(.+?)\.([a-z]+)$/;

    # discard format if the caller requested bml from an ancient link
    if ( $format && $format eq 'bml' ) {
        $format = undef;
    }

    # Role determination: if the URL starts with '/api/vX' then it's an API
    # call, and we should extract that information for our call options.
    if ( $uri =~ m!^/api/v(\d+)(/.+)$! ) {
        $opts{role}   = 'api';
        $opts{apiver} = $1 + 0;
        $format       = 'json';
        $uri          = $2;
    }

    # add more data to the options hash, we'll need it
    $opts{role} ||= $opts{username} ? 'user' : 'app';
    $opts{uri}    = $uri;
    $opts{format} = $format;

    # we construct this object as an easy way to get options later, it gives
    # us accessors.
    my $call_opts = DW::Routing::CallInfo->new( \%opts );

    # APIs are versioned, so we only want to check for endpoints that match
    # the version the user is requesting.
    if ( $call_opts->role eq 'api' ) {

        # return early if we weren't given an API version
        return unless defined( $call_opts->apiver );

        # check the static endpoints for this api version first
        if ( exists $api_endpoints{ $call_opts->apiver } ) {
            my $hash = $api_endpoints{ $call_opts->apiver }->{$uri};
            if ($hash) {
                $call_opts->init_call_opts($hash);
                return $call_opts;
            }
        }

        # if there's no static match, check the regexes
        my $endpoints_for_version = $api_rest_endpoints{ $call_opts->apiver };
        if ($endpoints_for_version) {

            # check for a match for each regex in this version
            foreach my $regex ( keys %{$endpoints_for_version} ) {

                # this actually checks the regex and, if there's a match,
                # populates the @args with matched groups
                if ( ( my @args = $uri =~ $regex ) ) {
                    my $call_def = $endpoints_for_version->{$regex};
                    $call_opts->init_call_opts( $call_def, \@args );
                    return $call_opts;
                }
            }
        }

        # if it's not found in either, just return.
        return;
    }

    # try the string options first as they're fast
    my $hash = $string_choices{ $call_opts->role . $uri };
    if ( defined $hash ) {
        $call_opts->init_call_opts($hash);
        return $call_opts;
    }

    # try the regex choices next
    # FIXME: this should be a dynamically sorting array so the most used items float to the top
    # for now it doesn't matter so much but eventually when everything is in the routing table
    # that will have to be done
    my @args;
    foreach $hash ( @{ $regex_choices{ $call_opts->role } } ) {
        if ( ( @args = $uri =~ $hash->{regex} ) ) {
            $call_opts->init_call_opts( $hash, \@args );
            return $call_opts;
        }
    }

    # failed to find anything so fall through
    return undef;
}

=head2 C<< $class->call_hash( $class, $call_opts ) >>

Calls the raw hash.

=cut

sub call_hash {
    my ( $class, $opts ) = @_;
    my $r = DW::Request->get;

    my $hash = $opts->call_opts;
    return undef unless $hash && $hash->{sub};

    $r->pnote( routing_opts => $opts );
    return $r->call_response_handler( \&_call_hash );
}

# INTERNAL METHOD: no POD
# Perl Response Handler for call_hash
sub _call_hash {
    my $r    = DW::Request->get;
    my $opts = $r->pnote('routing_opts');

    $opts->prepare_for_call;

    # check method
    my $method = uc( $r->method );
    return $r->HTTP_METHOD_NOT_ALLOWED unless $opts->method_valid($method);

    # check for format validity
    return $r->NOT_FOUND unless $opts->format_valid;

    # if renamed with redirect in place, then do the redirect
    if ( $opts->role eq 'user' && ( my $orig_u = LJ::load_user( $opts->username ) ) ) {
        my $renamed_u = $orig_u->get_renamed_user;

        if ( $renamed_u && !$orig_u->equals($renamed_u) ) {
            my $journal_host = $renamed_u->journal_base;
            $journal_host =~ s!https?://!!;

            return $r->redirect( LJ::create_url( $r->uri, host => $journal_host, keep_args => 1 ) );
        }
    }

    # apply default content type if it exists
    my $format = $opts->format;
    $r->content_type( $default_content_types->{$format} )
        if $default_content_types->{$format};

    # apply default cache-avoidant settings to "journal" content
    # (similar to the behavior of our Apache server modules)
    # so that proxies (e.g. Cloudflare) must revalidate the response
    if ( $opts->role eq 'user' && !$opts->no_cache ) {
        $r->header_out( "Cache-Control" => "private, proxy-revalidate" );
    }

    # apply no-cache if needed
    $r->no_cache if $opts->no_cache;

    # try to call the handler that actually does the content creation; it will
    # return either a number (HTTP code), or undef
    # means there was an error of some sort
    my $ret = eval { $opts->call };
    return $ret unless $@;

    # here down is simply error handling for whatever the handler sub above
    # might have died with
    my $msg = $@;

    my $err = LJ::errobj($msg)
        or die "LJ::errobj didn't return anything.";
    unless ($T_TESTING_ERRORS) {
        warn $msg;
    }

    # JSON error rendering
    if ( $format eq 'json' ) {
        $msg = $err->as_string;
        chomp $msg;

        my $text   = $LJ::MSG_ERROR || "Sorry, there was a problem.";
        my $remote = LJ::get_remote();

        $text = "$msg" if ( $remote && $remote->show_raw_errors ) || $LJ::IS_DEV_SERVER;

        $r->status(500);
        $r->print( to_json( { success => 0, error => $text } ) );
        return $r->OK;

        # default error rendering
    }
    elsif ( $format eq "html" ) {
        $msg = $err->as_html;
        chomp $msg;

        $msg .= " \@ $LJ::SERVER_NAME" if $LJ::SERVER_NAME;

        $r->status(500);
        $r->content_type( $default_content_types->{html} );

        my $text   = $LJ::MSG_ERROR || "Sorry, there was a problem.";
        my $remote = LJ::get_remote();
        $text = "<b>[Error: $msg]</b>"
            if ( $remote && $remote->show_raw_errors ) || $LJ::IS_DEV_SERVER;
        $opts->{no_sitescheme} = 1 if $T_TESTING_ERRORS;

        $ret = eval { return DW::Template->render_string( $text, $opts ); };
        return $ret unless $@;

        my $msg2 = $@;
        my $err2 = LJ::errobj($msg2)
            or die "LJ::errobj didn't return anything.";
        unless ($T_TESTING_ERRORS) {
            warn $msg2;
        }

        if ( ( $remote && $remote->show_raw_errors ) || $LJ::IS_DEV_SERVER ) {
            $msg2 = $err2->as_html;
            $msg2 .= " \@ $LJ::SERVER_NAME" if $LJ::SERVER_NAME;

            $text .= "\n<br/><br/>Additionally, while trying to render this error page:";
            $text .= "\n<b>[Error 2: $msg2]</b>";
        }

        $r->status(500);
        $r->content_type('text/html');
        $r->print($text);
        return $r->OK;
    }
    else {
        $msg = $err->as_string;
        chomp $msg;

        $msg .= " \@ $LJ::SERVER_NAME" if $LJ::SERVER_NAME;

        my $text   = $LJ::MSG_ERROR || "Sorry, there was a problem.";
        my $remote = LJ::get_remote();
        $text = "Error: $msg" if ( $remote && $remote->show_raw_errors ) || $LJ::IS_DEV_SERVER;

        $r->status(500);
        $r->content_type('text/plain');
        $r->print($text);

        return $r->OK;
    }
}

# INTERNAL METHOD: no POD
# controller sub for register_static
sub _static_helper {
    my $r = DW::Request->get;
    return DW::Template->render_template( $_[0]->args );
}

# INTERNAL METHOD: no POD
# controller sub for register_redirect
sub _redirect_helper {
    my $r    = DW::Request->get;
    my $data = $_[0]->args;

    my $dest = $data->{dest};
    if ( ref $dest eq "CODE" ) {
        my $get = $r->get_args;
        $dest = $dest->( { map { $_ => LJ::eurl( $get->{$_} ) } keys %$get } );
    }

    if ( $data->{full_uri} ) {
        return $r->redirect($dest);
    }
    else {
        return $r->redirect( LJ::create_url( $dest, keep_args => $data->{keep_args} ) );
    }
}

=head1 Registration API

=head2 C<< $class->register_static( $string, $filename, %opts ) >>

Static page helper.

=over

=item string - path

=item filename - template filename

=item Opts ( see register_string )

=back

=cut

sub register_static {
    my ( $class, $string, $fn, %opts ) = @_;

    $opts{args} = $fn;
    $class->register_string( $string, \&_static_helper, %opts );
}

=head2 C<< $class->register_string( $string, $sub, %opts ) >>

=over

=item string - path

=item sub - sub

=item Opts:

=over

=item args - passed verbatim to sub.

=item app - Serve this in app-space.

=item user - Serve this in journalspace.

=item format - What format should be used, defaults to HTML

=item formats - An array of possible formats, or 1 to allow everything.

=back

=back

=cut

sub register_string {
    my ( $class, $string, $sub, %opts ) = @_;

    my $hash = _apply_defaults(
        \%opts,
        {
            sub => $sub,
        }
    );

    $string_choices{ 'app' . $string }  = $hash if $hash->{app};
    $string_choices{ 'user' . $string } = $hash if $hash->{user};

    my %redirect_opts = (
        app          => $hash->{app},
        user         => $hash->{user},
        formats      => $hash->{formats},
        format       => $hash->{format},
        no_redirects => 1,
        keep_args    => 1,
    );

    if ( $string =~ m!(^(.*)/)index$! && !exists $opts{no_redirects} ) {
        $class->register_redirect( $2, $1, %redirect_opts ) if $2;
        $string_choices{ 'app' . $1 }  = $hash if $hash->{app};
        $string_choices{ 'user' . $1 } = $hash if $hash->{user};

    }
    elsif ( !exists $opts{no_redirects} ) {

        # for all other (non-index) pages, redirect page/ to page
        $class->register_redirect( "$string/", $string, %redirect_opts );

    }
}

=head2 C<< $class->register_redirect( $string, $dest, %opts ) >>

Redirect helper.

=over

=item string - path

=item dest - destination

=item Opts ( see register_string )

=over

=item keep_args - Persist GET arguments over redirect ( same as the keep_args argument to create_url ).

=item full_uri - A full URI ( http://...../foo v.s. /foo )

=back

=back

=cut

sub register_redirect {
    my ( $class, $string, $dest, %opts ) = @_;

    my $args = { dest => $dest };
    $args->{keep_args} = delete $opts{keep_args} || 0;
    $args->{full_uri}  = delete $opts{full_uri}  || 0;

    $opts{args} = $args;
    $class->register_string( $string, \&_redirect_helper, %opts );
}

=head2 C<< $class->register_regex( $regex, $sub, %opts ) >>

=over

=item regex

=item sub - sub

=item Opts ( see register_string )

=back

=cut

sub register_regex {
    my ( $class, $regex, $sub, %opts ) = @_;

    my $hash = _apply_defaults(
        \%opts,
        {
            regex => $regex,
            sub   => $sub,
        }
    );
    push @{ $regex_choices{app} },  $hash if $hash->{app};
    push @{ $regex_choices{user} }, $hash if $hash->{user};
    push @{ $regex_choices{api} },  $hash if $hash->{api};
}

=head2 C<< $class->register_rpc( $name, $sub, %opts ) >>

Register a RPC call

=over

=item name - RPC call name

=item sub - sub

=item Opts ( see register_string )

=back

=cut

sub register_rpc {
    my ( $class, $string, $sub, %opts ) = @_;

    delete $opts{app};
    delete $opts{user};
    $class->register_string( "/__rpc_$string", $sub, app => 1, user => 1, %opts );

    # FIXME: per Bug 4900, this line is temporary and can go away as soon as
    #  all the javascript is updated
    $class->register_regex( qr!^/[^/]+/\Q__rpc_$string\E$!, $sub, app => 1, user => 1, %opts );
}

=head2 C<< $class->register_api_endpoint( $string, $sub, %opts ) >>

=over

=item string

=item sub - sub

=item opts (see register_string)

=back

=cut

sub register_api_endpoint {
    my ( $class, $string, $sub, %opts ) = @_;
    croak 'register_api_endpoint must have version option'
        unless exists $opts{version};

    my $hash = _apply_defaults(
        \%opts,
        {
            sub    => $sub,
            format => 'json',
        }
    );

    my $vers =
        ref $opts{version} eq 'ARRAY'
        ? $opts{version}
        : [ $opts{version} + 0 ];
    croak 'register_api_version requires all versions >= 1'
        if grep { $_ <= 0 } @$vers;

    # Now register this string at all versions that they gave us.
    $api_endpoints{$_}->{$string} = $hash foreach @$vers;
}

# internal helper for speed construction ...
sub register_api_endpoints {
    my $class = shift;
    foreach my $row (@_) {
        $class->register_api_endpoint( $row->[0], $row->[1], version => $row->[2] );
    }
}

=head2 C<< $class->register_api_rest_endpoint( $string, $sub, %opts ) >>

=over

=item string

=item sub - sub

=item opts (see register_regex)

=back

=cut

sub register_api_rest_endpoint {
    my ( $class, $string, $sub, $controller_class, %opts ) = @_;

    croak 'register_api_rest_endpoint must have version option'
        unless exists $opts{version};

    my $hash = _apply_defaults(
        \%opts,
        {
            class  => $controller_class,
            sub    => $sub,
            format => 'json',
        }
    );

    my $vers =
        ref $opts{version} eq 'ARRAY'
        ? $opts{version}
        : [ $opts{version} + 0 ];
    croak 'register_api_version requires all versions >= 1'
        if grep { $_ <= 0 } @$vers;

    # Now register this string at all versions that they gave us.
    $api_rest_endpoints{$_}->{$string} = $hash foreach @$vers;
}

# internal helper for speed construction ...
sub register_api_rest_endpoints {
    my $class = shift;
    foreach my $row (@_) {
        $class->register_api_rest_endpoint( $row->[0], $row->[1], $row->[2], version => $row->[3] );
    }
}

# internal method, intentionally no POD
# applies default for opts and hash
sub _apply_defaults {
    my ( $opts, $hash ) = @_;

    $hash ||= {};
    $opts->{app}  = 1 if !defined $opts->{app} && !$opts->{user} && !$opts->{api};
    $hash->{args} = $opts->{args};
    $hash->{app}  = $opts->{app} || 0;
    $hash->{user} = $opts->{user} || 0;
    $hash->{api}  = $opts->{api} || 0;
    $hash->{format} ||= $opts->{format} || 'html';
    $hash->{no_cache} = $opts->{no_cache} || 0;

    my $formats = $opts->{formats} || [ $hash->{format} ];
    $formats = { map { ( $_, 1 ) } @$formats } if ref $formats eq 'ARRAY';

    $hash->{formats} = $formats;
    $hash->{methods} = $opts->{methods} || { GET => 1, POST => 1, HEAD => 1, DELETE => 1 };

    return $hash;
}

=head1 AUTHOR

=over

=item Andrea Nall <anall@andreanall.com>

=item Mark Smith <mark@dreamwidth.org>

=back

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2009-2013 by Dreamwidth Studios, LLC.

This program is free software; you may redistribute it and/or modify it under
the same terms as Perl itself. For a copy of the license, please reference
'perldoc perlartistic' or 'perldoc perlgpl'.

=cut

1;