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 Fripost::Schema::Util 'split_addr'; 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) = @_; my $d = (split_addr($u))[1]; unless (defined $d) { $CFG{default_realm} // return 0; $u .= '@'.$CFG{default_realm}; } my $fp = Fripost::Schema::->auth($u, $p, %CFG, -die => 0); return 0 unless defined $fp; $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/^$script//s; # Strip the facing CGI script name $uri =~ s/\?.*//s; # Strip the query map { decodeURIComponent($_); Encode::_utf8_on($_); $_ } (split '/', $uri); } =head1 AUTHOR Guilhem Moulin C<< >> =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__