path: root/lib/Fripost/Panel/Login.pm

package Fripost::Panel::Login;

use 5.010_000;
use strict;
use warnings;
use utf8;

=head1 NAME

Login.pm - Authentication subroutines for the Web Interface.

=cut

use parent 'CGI::Application';
use CGI::Application::Plugin::AutoRunmode;
use CGI::Application::Plugin::Session;
use CGI::Application::Plugin::Authentication;
use CGI::Application::Plugin::Redirect;
use CGI::Application::Plugin::ConfigAuto 'cfg';

use Fripost::Schema;

use HTML::Entities 'encode_entities';
use URI::Escape::XS 'decodeURIComponent';
use Encode ();

# This method is called right before the 'setup' method below. It
# initializes the session and authentication configurations.
sub cgiapp_init {
    my $self = shift;

    my %CFG = $self->cfg;

    $self->session_config(
        CGI_SESSION_OPTIONS => [ 'driver:DB_File;serializer:freezethaw'
                               , $self->query
                               , { FileName => $CFG{session_db_filename},
                                   UMask => 0600 }
                               , { name => $CFG{session_authname} }
                               ],
        DEFAULT_EXPIRY      => $CFG{session_expire},
        COOKIE_PARAMS       => { -name     => $CFG{session_authname}
                               , -path     => $CFG{'cgi-bin'}
                               # Expires when the browser quits
                               , -expires  => -1
                               ,'-max-age' => -1
                               , -secure   => $CFG{secure_cookie}
                               # We are not using JavaScript in this framework
                               , -httponly => 1
                               },
       SEND_COOKIE          => 1,
    );

    # Configure authentication parameters
    $self->authen->config(
        DRIVER                => [ 'Generic', sub {
            my ($u,$p) = @_;
            unless ($u =~ /\@/) {
                $CFG{default_realm} // return 0;
                $u .= '@'.$CFG{default_realm};
            }
            my $fp = Fripost::Schema::->auth($u, $p, \%CFG, -error => undef)
                         // return 0;
            $fp->done;
            return $u;
        } ],
        STORE                 => 'Session',
        LOGIN_RUNMODE         => 'login',
        RENDER_LOGIN          => \&login_box,
        LOGIN_SESSION_TIMEOUT => { IDLE_FOR => $CFG{timeout} },
        LOGOUT_RUNMODE        => 'logout',
    );

    # The run modes that require authentication
    $self->authen->protected_runmodes( qw/okay error_rm/ );
}


# This method is called by the inherited new() constructor method.
# It defines the path for templates and chooses the Run Mode depending
# on the URL and query string.
sub setup {
    my $self = shift;
    $self->header_props( -charset=>'utf-8' );

    $self->tmpl_path( $self->cfg('tmpl_path') );

    $self->mode_param( sub {
        my $self = shift;
        my $q = $self->query;

        # The user just logged in
        return 'okay' if defined $q->param('login');
        my $a = $q->param('a');

        return 'login' if defined $a and $a eq 'login';
        return 'logout' if defined $a and $a eq 'logout';

        # /domain/{user,alias,list}/?query_url
        my ($null,$domain,$local,$crap) = $self->split_path;

        return 'ListDomains' if $null;

        unless ($domain) {
            if (defined $a) {
                return 'AddDomain' if $a eq 'add';
            }
            return 'ListDomains';
        }

        unless ($local) {
            if (defined $a) {
                return 'EditDomain' if $a eq 'edit';
                return 'AddLocal' if $a eq 'add';
            }
            return 'ListLocals';
        }

        return 'EditLocal';
    });
}


# This Run Mode redirects the freshly logged in user to the URL s/he
# wanted to visit.
sub okay : Runmode {
    my $self = shift;
    my $redirect = $self->query->param('redirect') // $self->query->url;
    return $self->redirect($redirect);
}


# This is the login Run Mode.
sub login : Runmode {
    my $self = shift;

    # A logged user has no reason to ask for a relogin, so s/he is seen as
    # an intruder
    $self->authen->logout if $self->authen->is_authenticated;

    # Do not come back here on the next Run Mode
    $self->query->delete('a') if defined $self->query->param('a') and
                                 $self->query->param('a') eq 'login';

    # Where the users wants to go
    $self->query->param( redirect => $self->query->self_url)
        unless defined $self->query->param('redirect');

    return $self->login_box;
}


# This method loads the login form.
sub login_box {
    my $self = shift;

    my $template = $self->load_tmpl( 'login.html', cache => 1 );
    $template->param( error => $self->authen->login_attempts );
    $template->param( redirect => $self->query->param('redirect') );

    return $template->output;
}


# This is the logout Run Mode.
sub logout : Runmode {
    my $self = shift;

    if ($self->authen->is_authenticated) {
        # Log out the user, delete the session and flush it off the disk
        $self->authen->logout;
        $self->session->delete;
        $self->session->flush;
    }

    # Do not come back here on the next Run Mode
    $self->query->delete('a') if defined $self->query->param('a') and
                                 $self->query->param('a') eq 'logout';

    return $self->redirect( ($ENV{SCRIPT_NAME} // $self->query->url).'/' );
}

# This is the error Run Mode.
sub error_rm : ErrorRunmode {
    my $self = shift;
    my $error = shift;

    if ($error =~ /^4\d+$/) {
        # HTTP client error.
        chomp $error;
        $self->header_props ( -status => $error );
        my $template = $self->load_tmpl( 'error_http.html', cache => 1 );
        my $mesg;
        if ($error eq '403' ) {
            $mesg = 'Forbidden'
        }
        elsif ($error eq '404' ) {
            $mesg = 'Not Found'
        }
        $template->param( code => $error );
        $template->param( message => encode_entities ($mesg) );
        return $template->output;
    }

    else {
        # Users are not supposed to see that unless the CGI crashes :P
        my $template = $self->load_tmpl( 'error.html', cache => 1 );
        $template->param( email => $self->cfg('report_email') );
        $template->param( message => encode_entities ($error) );
        $template->param( url => $self->query->url . '/');
        return $template->output;
    }
}

# Split the URI; give the list of its components.
# The facing CGI script and trailing query are not considered.
sub split_path {
    my $self = shift;
    my %options = @_;

    my $script = $ENV{SCRIPT_NAME} // $self->cfg->{'cgi-bin'} // '';
    $script =~ s@/$@@s; # Strip the trailing '/' off the script name

    my $uri = $self->query->request_uri;
    $uri =~ s/^\Q$script\E\b//s; # Strip the facing CGI script name
    $uri =~ s/\?.*//s;           # Strip the query

    map { my $x = decodeURIComponent($_); Encode::_utf8_on($x); $x }
        (split '/', $uri);
}


=head1 AUTHOR

Guilhem Moulin C<< <guilhem at fripost.org> >>

=head1 COPYRIGHT

Copyright 2012,2013 Guilhem Moulin.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as perl itself.

=cut

1;

__END__