From ec17f0ce71a233025768a54b4a1beae34e2b8a45 Mon Sep 17 00:00:00 2001
From: Guilhem Moulin <guilhem.moulin@fripost.org>
Date: Sun, 9 Sep 2012 21:01:45 +0200
Subject: =?UTF-8?q?lib/FPanel/=20=E2=86=92=20lib/Fripost/Panel/?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
---
cgi-bin/index.cgi | 4 +-
lib/FPanel/Interface.pm | 437 -----------------------------------------
lib/FPanel/Login.pm | 241 -----------------------
lib/Fripost/Panel/Interface.pm | 437 +++++++++++++++++++++++++++++++++++++++++
lib/Fripost/Panel/Login.pm | 241 +++++++++++++++++++++++
server.pl | 4 +-
6 files changed, 682 insertions(+), 682 deletions(-)
delete mode 100644 lib/FPanel/Interface.pm
delete mode 100644 lib/FPanel/Login.pm
create mode 100644 lib/Fripost/Panel/Interface.pm
create mode 100644 lib/Fripost/Panel/Login.pm
diff --git a/cgi-bin/index.cgi b/cgi-bin/index.cgi
index 89290e8..5efa469 100755
--- a/cgi-bin/index.cgi
+++ b/cgi-bin/index.cgi
@@ -12,7 +12,7 @@ index.cgi -
=cut
use lib 'lib';
-use FPanel::Interface;
+use Fripost::Panel::Interface;
# TODO: Try out Fast CGI
#use CGI::Fast();
@@ -25,7 +25,7 @@ use FPanel::Interface;
my @config = 'default.in';
push @config, 'config.in' if -f 'config.in';
-my $cgi = FPanel::Interface->new(
+my $cgi = Fripost::Panel::Interface->new(
PARAMS => { cfg_file => [ @config ], format => 'equal' }
);
$cgi->run();
diff --git a/lib/FPanel/Interface.pm b/lib/FPanel/Interface.pm
deleted file mode 100644
index 053e1a2..0000000
--- a/lib/FPanel/Interface.pm
+++ /dev/null
@@ -1,437 +0,0 @@
-package FPanel::Interface;
-
-use 5.010_000;
-use strict;
-use warnings;
-use utf8;
-
-=head1 NAME
-
-Interface.pm -
-
-=cut
-
-use Fripost::Schema;
-use Fripost::Password;
-use parent 'FPanel::Login';
-use HTML::Entities;
-
-
-# This method is called right before the 'setup' method below. It
-# inherits the configuration from the super class.
-sub cgiapp_init {
- my $self = shift;
- $self->SUPER::cgiapp_init;
-
- # Every single Run Mode here is protected
- $self->authen->protected_runmodes( ':all' );
-}
-
-
-# This is the first page seen by authenticated users. It lists the known
-# domains.
-sub ListDomains : StartRunmode {
- my $self = shift;
- my %CFG = $self->cfg;
-
- my ($ul,$ud) = split /\@/, $self->authen->username, 2;
-
- my $fp = Fripost::Schema->SASLauth( $self->authen->username, %CFG );
- my @domains = $fp->domain->search( -concat => "\n", -die => 403);
- $fp->done;
-
- my $template = $self->load_tmpl( 'list-domains.html', cache => 1, utf8 => 1
- , loop_context_vars => 1
- , global_vars => 1 );
- $template->param( url => $self->query->url
- , user_localpart => $ul
- , user_domainpart => $ud
- , domains => [ @domains ]
- );
- return $template->output;
-}
-
-
-# This Run Mode lists the known mailboxes, aliases and lists under the current
-# domain.
-sub ListLocals : Runmode {
- my $self = shift;
- my %CFG = $self->cfg;
-
- my ($ul,$ud) = split /\@/, $self->authen->username, 2;
- my $d = (split /\//, $ENV{PATH_INFO}, 3)[1];
- my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
-
- # Query *the* matching domain
- my %domain = $fp->domain->get( $d, -die => 404 );
-
- # Query the mailboxes, aliases and lists under the given domain. We
- # don't die with a HTTP error code here, as it is not supposed to
- # crash.
- my @mailboxes = $fp->mailbox->search( $d );
- my @aliases = $fp->alias->search( $d );
- my @lists = $fp->list->search( $d );
-
- $fp->done;
-
- my $template = $self->load_tmpl( 'list-locals.html', cache => 1, utf8 => 1
- , loop_context_vars => 1
- , global_vars => 1 );
-
- $template->param( url => $self->query->url
- , user_localpart => $ul
- , user_domainpart => $ud
- );
- $template->param( domain => $domain{domain}
- , isactive => $domain{isactive}
- , description => join ("\n", @{$domain{description}}) );
- # Can the user edit the domain (change description, toggle
- # activation, modify catchalls?)
- $template->param( canEditDomain => $domain{permissions} =~ /[op]/ );
-
- # Can the user add mailboxes?
- $template->param( canAddMailbox => $domain{permissions} =~ /p/ );
- # Should we list mailboxes?
- $template->param( listMailboxes => $#mailboxes >= 0 ||
- $domain{permissions} =~ /p/ );
- $template->param( mailboxes => [
- map { { user => $_->{user}
- , description => join ("\n", @{$_->{description}})
- , isactive => $_->{isactive}
- , forwards => [ map { {forward => $_} } @{$_->{forwards}} ]
- , quota => $_->{quota}
- };
- }
- @mailboxes
- ]);
-
- # Can the user add aliases?
- $template->param( canAddalias => $domain{permissions} =~ /[aop]/ );
- # Should we list aliases?
- $template->param( listAliases => $#aliases >= 0 ||
- $domain{permissions} =~ /[aop]/ );
- $template->param( aliases => [
- map { { alias => $_->{alias}
- , description => join ("\n", @{$_->{description}})
- , isactive => $_->{isactive}
- , destinations => [ map { {destination => $_} }
- @{$_->{maildrop}} ]
- };
- }
- @aliases
- ]);
- $template->param( catchalls => [ map { {catchall => $_} }
- @{$domain{catchalls}} ]
- , CAodd => not $#aliases % 2);
-
- # Can the user add lists?
- $template->param( canAddList => $domain{permissions} =~ /[lop]/ );
- # Should we list lists?
- $template->param( listLists => $#lists >= 0 || $domain{permissions} =~ /[lop]/ );
- $template->param( lists => [
- map { { list => $_->{list}
- , description => join ("\n", @{$_->{description}})
- , isactive => $_->{isactive}
- , transport => $_->{transport}
- };
- }
- @lists
- ]);
- return $template->output;
-}
-
-
-# In this Run Mode authenticated users can edit the domain description
-# and catchalls, and toggle activation (if they have the permission).
-sub EditDomain : Runmode {
- my $self = shift;
- my %CFG = $self->cfg;
-
- my ($ul,$ud) = split /\@/, $self->authen->username, 2;
- my $d = (split /\//, $ENV{PATH_INFO}, 3)[1];
-
- my $q = $self->query;
- return $self->redirect($q->url .'/') if defined $q->param('cancel');
-
- my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
-
- my $error; # Tells whether the change submission has failed.
- if (defined $q->param('submit')) {
- # Changes have been submitted: process them
- $error = $fp->domain->replace({
- domain => $d,
- isactive => $q->param('isactive'),
- description => $q->param('description'),
- catchalls => $q->param('catchalls')
- }, -concat => "(\n|\x{0D}\x{0A})");
- }
- my %domain = $fp->domain->get( $d, -die => 404 );
- $fp->done;
-
- my $template = $self->load_tmpl( 'edit-domain.html', cache => 1, utf8 => 1
- , loop_context_vars => 1
- , global_vars => 1 );
- $template->param( url => $self->query->url
- , user_localpart => $ul
- , user_domainpart => $ud
- , domain => $d
- );
- if ($error) {
- # Preserve the (incorrect) form
- $template->param( isactive => $q->param('isactive')
- , description => $q->param('description')
- , catchalls => $q->param('catchalls')
- , error => encode_entities ($error, "‘‘") );
- }
- else {
- $template->param( isactive => $domain{isactive}
- , description => join ("\x{0D}\x{0A}",
- @{$domain{description}})
- , catchalls => join ("\x{0D}\x{0A}",
- @{$domain{catchalls}}) );
- }
- $template->param( newChanges => defined $self->query->param('submit') );
- return $template->output;
-}
-
-
-# In this Run Mode authenticated users can edit the entry (if they have
-# the permission).
-sub EditLocal : Runmode {
- my $self = shift;
- my %CFG = $self->cfg;
-
- my ($ul,$ud) = split /\@/, $self->authen->username, 2;
- my ($null,$d,$l,$crap) = split /\//, $ENV{PATH_INFO}, 4;
-
- my $q = $self->query;
- return $self->redirect($q->url.'/'.$d.'/') if defined $q->param('cancel');
-
- my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
-
- my $error; # Tells whether the change submission has failed.
- if (defined $q->param('submit')) {
- # Changes have been submitted: process them
- my $t = $q->param('t') // die "Undefined type";
- my %entry;
- if ($t eq 'mailbox') {
- $entry{user} = $l.'@'.$d;
- $entry{forwards} = $q->param('forwards');
-
- if ($q->param('oldpw') ne '' or
- $q->param('newpw') ne '' or
- $q->param('newpw2') ne '') {
- # If the user tries to change the password, we make her
- # bind first, to prevent an attacker from setting a
- # custom password and accessing the emails.
- if ($q->param('newpw') ne $q->param('newpw2')) {
- $error = "Passwords do not match";
- }
- elsif (length $q->param('newpw') < $CFG{password_min_length}) {
- $error = "Password should be at least "
- .$CFG{password_min_length}
- ." characters long.";
- }
- else {
- my $fp;
- eval {
- $fp = Fripost::Schema::->auth(
- $self->authen->username,
- $q->param('oldpw'),
- ldap_uri => $CFG{ldap_uri},
- ldap_suffix => $CFG{ldap_suffix},
- -die => "Wrong password (for ‘"
- .$self->authen->username."‘)." );
- };
- $error = $@ || $fp->mailbox->passwd(
- $entry{user},
- Fripost::Password::hash($q->param('newpw'))
- );
- $fp->done if defined $fp;
- }
- }
- }
- elsif ($t eq 'alias') {
- $entry{alias} = $l.'@'.$d;
- $entry{maildrop} = $q->param('maildrop');
- }
- elsif ($t eq 'list') {
- $entry{list} = $l.'@'.$d;
- $entry{transport} = $q->param('transport');
- }
- else {
- # Unknown type
- return $self->redirect($q->url .'/'. $d .'/');
- }
- $entry{isactive} = $q->param('isactive');
- $entry{description} = $q->param('description');
- $error = $fp->$t->replace( \%entry, -concat => "(\n|\x{0D}\x{0A})")
- unless $error;
- }
-
- # Search for *the* matching mailbox, alias or list.
- my %local = $fp->local->get ($l, $d, -die => 404,
- -concat => "\x{0D}\x{0A}");
- $fp->done;
-
- my $template = $self->load_tmpl( "edit-$local{type}.html",
- cache => 1, utf8 => 1 );
- $template->param( url => $self->query->url
- , user_localpart => $ul
- , user_domainpart => $ud
- , domain => $d
- );
- if ($error) {
- # Preserve the (incorrect) form, except the passwords
- if ($local{type} eq 'mailbox') {
- $template->param( user => $l
- , forwards => $q->param('forwards') );
- }
- elsif ($local{type} eq 'alias') {
- $template->param( alias => $l
- , maildrop => $q->param('maildrop') );
- }
- elsif ($local{type} eq 'list') {
- $template->param( list => $l );
- }
- else {
- # Unknown type
- return $self->redirect($q->url.'/'.$d.'/');
- }
- $template->param( isactive => $q->param('isactive')
- , description => $q->param('description')
- , error => encode_entities ($error, "‘‘") );
- }
- else {
- if ($local{type} eq 'mailbox') {
- $template->param( user => $local{user}
- , forwards => $local{forwards} );
- }
- elsif ($local{type} eq 'alias') {
- $template->param( alias => $local{alias}
- , maildrop => $local{maildrop} );
- }
- elsif ($local{type} eq 'list') {
- $template->param( list => $local{list} );
- }
- else {
- # Unknown type
- return $self->redirect($q->url.'/'.$d.'/');
- }
- $template->param( isactive => $local{isactive}
- , description => $local{description} );
- }
- $template->param( newChanges => defined $self->query->param('submit') );
- return $template->output;
-}
-
-
-# In this Run Mode authenticated users can add mailboxes, aliases and
-# lists (if they have the permission).
-sub AddLocal : Runmode {
- my $self = shift;
- my %CFG = $self->cfg;
-
- my ($ul,$ud) = split /\@/, $self->authen->username, 2;
- my $d = (split /\//, $ENV{PATH_INFO}, 3)[1];
-
- my $q = $self->query;
- return $self->redirect($q->url.'/'.$d.'/') if defined $q->param('cancel');
-
- my $t = $q->param('t') // die "Undefined type";
- my $error; # Tells whether the change submission has failed.
- if (defined $q->param('submit')) {
- # Changes have been submitted: process them
- my %entry;
- if ($t eq 'mailbox') {
- $entry{user} = $q->param('user').'@'.$d;
- $entry{forwards} = $q->param('forwards');
- if ($q->param('password') ne $q->param('password2')) {
- $error = "Passwords do not match";
- }
- elsif (length $q->param('password') < $CFG{password_min_length}) {
- $error = "Password should be at least "
- .$CFG{password_min_length}
- ." characters long.";
- }
- else {
- $entry{password} = Fripost::Password::hash($q->param('password'));
- }
- # TODO: inherit the quota from the postmaster's?
- }
- elsif ($t eq 'alias') {
- $entry{alias} = $q->param('alias').'@'.$d;
- $entry{maildrop} = $q->param('maildrop');
- }
- elsif ($t eq 'list') {
- $entry{list} = $q->param('list').'@'.$d;
- $entry{transport} = $q->param('transport');
- }
- else {
- # Unknown type
- return $self->redirect($q->url.'/'.$d.'/');
- }
- $entry{isactive} = $q->param('isactive');
- $entry{description} = $q->param('description');
-
- unless ($error) {
- my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
- $error = $fp->$t->add( \%entry, -concat => "(\n|\x{0D}\x{0A})");
- $fp->done;
- return $self->redirect($q->url.'/'.$d.'/') unless $error;
- }
- }
-
- my $template = $self->load_tmpl( "add-$t.html", cache => 1, utf8 => 1 );
- $template->param( url => $self->query->url
- , user_localpart => $ul
- , user_domainpart => $ud
- , domain => $d
- );
- if ($error) {
- # Preserve the (incorrect) form, except the passwords
- if ($t eq 'mailbox') {
- $template->param( user => $q->param('user')
- , forwards => $q->param('forwards') );
- }
- elsif ($t eq 'alias') {
- $template->param( alias => $q->param('alias')
- , maildrop => $q->param('maildrop') );
- }
- elsif ($t eq 'list') {
- $template->param( list => $q->param('list')
- , isenc => $q->param('transport') eq 'schleuder' );
- }
- else {
- # Unknown type
- return $self->redirect($q->url.'/'.$d.'/');
- }
- $template->param( isactive => $q->param('isactive')
- , description => $q->param('description')
- , error => encode_entities ($error, "‘‘") );
- }
- else {
- $template->param( isactive => 1 );
- }
- return $template->output;
-}
-
-
-=head1 AUTHOR
-
-Guilhem Moulin C<< <guilhem at fripost.org> >>
-
-=head1 COPYRIGHT
-
-Copyright 2012 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__
diff --git a/lib/FPanel/Login.pm b/lib/FPanel/Login.pm
deleted file mode 100644
index ab7bf36..0000000
--- a/lib/FPanel/Login.pm
+++ /dev/null
@@ -1,241 +0,0 @@
-package FPanel::Login;
-
-use 5.010_000;
-use strict;
-use warnings;
-use utf8;
-
-=head1 NAME
-
-Login.pm -
-
-=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 Net::LDAP;
-use Authen::SASL;
-use File::Spec::Functions qw/catfile catdir/;
-use HTML::Entities;
-
-
-# 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 ($l,$d) = split /\@/, $u, 2;
-
- unless (defined $d) {
- $CFG{default_realm} // return 0;
- $d = $CFG{default_realm};
- $u .= '@'.$d;
- }
- my $bind_dn = "fvu=$l,fvd=$d,". join (',', @{$CFG{ldap_suffix}});
-
- my $ldap = Net::LDAP->new( $CFG{ldap_uri} );
- my $mesg = $ldap->bind ( $bind_dn, password => $p );
- $ldap->unbind;
- $mesg->code ? 0 : $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( catdir ( $self->cfg('pwd'), $self->cfg('tmpl_path') ) );
-
- $self->mode_param( sub {
- my $self = shift;
- my $q = $self->query;
- print STDERR $ENV{PATH_INFO} . '?' . $q->query_string, "\n";
-
- # 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) = split /\//, $ENV{PATH_INFO};
-
- return 'ListDomains' unless (defined $null) and $null eq '';
-
- unless (defined $domain and $domain ne '') {
- if (defined $a) {
- return 'AddDomain' if $a eq 'add';
- }
- return 'ListDomains';
- }
-
- unless (defined $local and $local ne '') {
- 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 $destination = $self->query->param('destination') //
- $self->query->url;
- return $self->redirect($destination);
-}
-
-
-# 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( destination => $self->query->self_url)
- unless defined $self->query->param('destination');
-
- 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, utf8 => 1 );
- $template->param( error => $self->authen->login_attempts );
- $template->param( destination => $self->query->param('destination') );
-
- 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($self->query->self_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, utf8 => 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, utf8 => 1 );
- $template->param( email => $self->cfg('report_email') );
- $template->param( message => $error );
- $template->param( url => $self->query->url . '/');
- return $template->output;
- }
-}
-
-
-=head1 AUTHOR
-
-Guilhem Moulin C<< <guilhem at fripost.org> >>
-
-=head1 COPYRIGHT
-
-Copyright 2012 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__
diff --git a/lib/Fripost/Panel/Interface.pm b/lib/Fripost/Panel/Interface.pm
new file mode 100644
index 0000000..b636861
--- /dev/null
+++ b/lib/Fripost/Panel/Interface.pm
@@ -0,0 +1,437 @@
+package Fripost::Panel::Interface;
+
+use 5.010_000;
+use strict;
+use warnings;
+use utf8;
+
+=head1 NAME
+
+Interface.pm -
+
+=cut
+
+use parent 'Fripost::Panel::Login';
+use Fripost::Schema;
+use Fripost::Password;
+use HTML::Entities;
+
+
+# This method is called right before the 'setup' method below. It
+# inherits the configuration from the super class.
+sub cgiapp_init {
+ my $self = shift;
+ $self->SUPER::cgiapp_init;
+
+ # Every single Run Mode here is protected
+ $self->authen->protected_runmodes( ':all' );
+}
+
+
+# This is the first page seen by authenticated users. It lists the known
+# domains.
+sub ListDomains : StartRunmode {
+ my $self = shift;
+ my %CFG = $self->cfg;
+
+ my ($ul,$ud) = split /\@/, $self->authen->username, 2;
+
+ my $fp = Fripost::Schema->SASLauth( $self->authen->username, %CFG );
+ my @domains = $fp->domain->search( -concat => "\n", -die => 403);
+ $fp->done;
+
+ my $template = $self->load_tmpl( 'list-domains.html', cache => 1, utf8 => 1
+ , loop_context_vars => 1
+ , global_vars => 1 );
+ $template->param( url => $self->query->url
+ , user_localpart => $ul
+ , user_domainpart => $ud
+ , domains => [ @domains ]
+ );
+ return $template->output;
+}
+
+
+# This Run Mode lists the known mailboxes, aliases and lists under the current
+# domain.
+sub ListLocals : Runmode {
+ my $self = shift;
+ my %CFG = $self->cfg;
+
+ my ($ul,$ud) = split /\@/, $self->authen->username, 2;
+ my $d = (split /\//, $ENV{PATH_INFO}, 3)[1];
+ my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
+
+ # Query *the* matching domain
+ my %domain = $fp->domain->get( $d, -die => 404 );
+
+ # Query the mailboxes, aliases and lists under the given domain. We
+ # don't die with a HTTP error code here, as it is not supposed to
+ # crash.
+ my @mailboxes = $fp->mailbox->search( $d );
+ my @aliases = $fp->alias->search( $d );
+ my @lists = $fp->list->search( $d );
+
+ $fp->done;
+
+ my $template = $self->load_tmpl( 'list-locals.html', cache => 1, utf8 => 1
+ , loop_context_vars => 1
+ , global_vars => 1 );
+
+ $template->param( url => $self->query->url
+ , user_localpart => $ul
+ , user_domainpart => $ud
+ );
+ $template->param( domain => $domain{domain}
+ , isactive => $domain{isactive}
+ , description => join ("\n", @{$domain{description}}) );
+ # Can the user edit the domain (change description, toggle
+ # activation, modify catchalls?)
+ $template->param( canEditDomain => $domain{permissions} =~ /[op]/ );
+
+ # Can the user add mailboxes?
+ $template->param( canAddMailbox => $domain{permissions} =~ /p/ );
+ # Should we list mailboxes?
+ $template->param( listMailboxes => $#mailboxes >= 0 ||
+ $domain{permissions} =~ /p/ );
+ $template->param( mailboxes => [
+ map { { user => $_->{user}
+ , description => join ("\n", @{$_->{description}})
+ , isactive => $_->{isactive}
+ , forwards => [ map { {forward => $_} } @{$_->{forwards}} ]
+ , quota => $_->{quota}
+ };
+ }
+ @mailboxes
+ ]);
+
+ # Can the user add aliases?
+ $template->param( canAddalias => $domain{permissions} =~ /[aop]/ );
+ # Should we list aliases?
+ $template->param( listAliases => $#aliases >= 0 ||
+ $domain{permissions} =~ /[aop]/ );
+ $template->param( aliases => [
+ map { { alias => $_->{alias}
+ , description => join ("\n", @{$_->{description}})
+ , isactive => $_->{isactive}
+ , destinations => [ map { {destination => $_} }
+ @{$_->{maildrop}} ]
+ };
+ }
+ @aliases
+ ]);
+ $template->param( catchalls => [ map { {catchall => $_} }
+ @{$domain{catchalls}} ]
+ , CAodd => not $#aliases % 2);
+
+ # Can the user add lists?
+ $template->param( canAddList => $domain{permissions} =~ /[lop]/ );
+ # Should we list lists?
+ $template->param( listLists => $#lists >= 0 || $domain{permissions} =~ /[lop]/ );
+ $template->param( lists => [
+ map { { list => $_->{list}
+ , description => join ("\n", @{$_->{description}})
+ , isactive => $_->{isactive}
+ , transport => $_->{transport}
+ };
+ }
+ @lists
+ ]);
+ return $template->output;
+}
+
+
+# In this Run Mode authenticated users can edit the domain description
+# and catchalls, and toggle activation (if they have the permission).
+sub EditDomain : Runmode {
+ my $self = shift;
+ my %CFG = $self->cfg;
+
+ my ($ul,$ud) = split /\@/, $self->authen->username, 2;
+ my $d = (split /\//, $ENV{PATH_INFO}, 3)[1];
+
+ my $q = $self->query;
+ return $self->redirect($q->url .'/') if defined $q->param('cancel');
+
+ my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
+
+ my $error; # Tells whether the change submission has failed.
+ if (defined $q->param('submit')) {
+ # Changes have been submitted: process them
+ $error = $fp->domain->replace({
+ domain => $d,
+ isactive => $q->param('isactive'),
+ description => $q->param('description'),
+ catchalls => $q->param('catchalls')
+ }, -concat => "(\n|\x{0D}\x{0A})");
+ }
+ my %domain = $fp->domain->get( $d, -die => 404 );
+ $fp->done;
+
+ my $template = $self->load_tmpl( 'edit-domain.html', cache => 1, utf8 => 1
+ , loop_context_vars => 1
+ , global_vars => 1 );
+ $template->param( url => $self->query->url
+ , user_localpart => $ul
+ , user_domainpart => $ud
+ , domain => $d
+ );
+ if ($error) {
+ # Preserve the (incorrect) form
+ $template->param( isactive => $q->param('isactive')
+ , description => $q->param('description')
+ , catchalls => $q->param('catchalls')
+ , error => encode_entities ($error, "‘‘") );
+ }
+ else {
+ $template->param( isactive => $domain{isactive}
+ , description => join ("\x{0D}\x{0A}",
+ @{$domain{description}})
+ , catchalls => join ("\x{0D}\x{0A}",
+ @{$domain{catchalls}}) );
+ }
+ $template->param( newChanges => defined $self->query->param('submit') );
+ return $template->output;
+}
+
+
+# In this Run Mode authenticated users can edit the entry (if they have
+# the permission).
+sub EditLocal : Runmode {
+ my $self = shift;
+ my %CFG = $self->cfg;
+
+ my ($ul,$ud) = split /\@/, $self->authen->username, 2;
+ my ($null,$d,$l,$crap) = split /\//, $ENV{PATH_INFO}, 4;
+
+ my $q = $self->query;
+ return $self->redirect($q->url.'/'.$d.'/') if defined $q->param('cancel');
+
+ my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
+
+ my $error; # Tells whether the change submission has failed.
+ if (defined $q->param('submit')) {
+ # Changes have been submitted: process them
+ my $t = $q->param('t') // die "Undefined type";
+ my %entry;
+ if ($t eq 'mailbox') {
+ $entry{user} = $l.'@'.$d;
+ $entry{forwards} = $q->param('forwards');
+
+ if ($q->param('oldpw') ne '' or
+ $q->param('newpw') ne '' or
+ $q->param('newpw2') ne '') {
+ # If the user tries to change the password, we make her
+ # bind first, to prevent an attacker from setting a
+ # custom password and accessing the emails.
+ if ($q->param('newpw') ne $q->param('newpw2')) {
+ $error = "Passwords do not match";
+ }
+ elsif (length $q->param('newpw') < $CFG{password_min_length}) {
+ $error = "Password should be at least "
+ .$CFG{password_min_length}
+ ." characters long.";
+ }
+ else {
+ my $fp;
+ eval {
+ $fp = Fripost::Schema::->auth(
+ $self->authen->username,
+ $q->param('oldpw'),
+ ldap_uri => $CFG{ldap_uri},
+ ldap_suffix => $CFG{ldap_suffix},
+ -die => "Wrong password (for ‘"
+ .$self->authen->username."‘)." );
+ };
+ $error = $@ || $fp->mailbox->passwd(
+ $entry{user},
+ Fripost::Password::hash($q->param('newpw'))
+ );
+ $fp->done if defined $fp;
+ }
+ }
+ }
+ elsif ($t eq 'alias') {
+ $entry{alias} = $l.'@'.$d;
+ $entry{maildrop} = $q->param('maildrop');
+ }
+ elsif ($t eq 'list') {
+ $entry{list} = $l.'@'.$d;
+ $entry{transport} = $q->param('transport');
+ }
+ else {
+ # Unknown type
+ return $self->redirect($q->url .'/'. $d .'/');
+ }
+ $entry{isactive} = $q->param('isactive');
+ $entry{description} = $q->param('description');
+ $error = $fp->$t->replace( \%entry, -concat => "(\n|\x{0D}\x{0A})")
+ unless $error;
+ }
+
+ # Search for *the* matching mailbox, alias or list.
+ my %local = $fp->local->get ($l, $d, -die => 404,
+ -concat => "\x{0D}\x{0A}");
+ $fp->done;
+
+ my $template = $self->load_tmpl( "edit-$local{type}.html",
+ cache => 1, utf8 => 1 );
+ $template->param( url => $self->query->url
+ , user_localpart => $ul
+ , user_domainpart => $ud
+ , domain => $d
+ );
+ if ($error) {
+ # Preserve the (incorrect) form, except the passwords
+ if ($local{type} eq 'mailbox') {
+ $template->param( user => $l
+ , forwards => $q->param('forwards') );
+ }
+ elsif ($local{type} eq 'alias') {
+ $template->param( alias => $l
+ , maildrop => $q->param('maildrop') );
+ }
+ elsif ($local{type} eq 'list') {
+ $template->param( list => $l );
+ }
+ else {
+ # Unknown type
+ return $self->redirect($q->url.'/'.$d.'/');
+ }
+ $template->param( isactive => $q->param('isactive')
+ , description => $q->param('description')
+ , error => encode_entities ($error, "‘‘") );
+ }
+ else {
+ if ($local{type} eq 'mailbox') {
+ $template->param( user => $local{user}
+ , forwards => $local{forwards} );
+ }
+ elsif ($local{type} eq 'alias') {
+ $template->param( alias => $local{alias}
+ , maildrop => $local{maildrop} );
+ }
+ elsif ($local{type} eq 'list') {
+ $template->param( list => $local{list} );
+ }
+ else {
+ # Unknown type
+ return $self->redirect($q->url.'/'.$d.'/');
+ }
+ $template->param( isactive => $local{isactive}
+ , description => $local{description} );
+ }
+ $template->param( newChanges => defined $self->query->param('submit') );
+ return $template->output;
+}
+
+
+# In this Run Mode authenticated users can add mailboxes, aliases and
+# lists (if they have the permission).
+sub AddLocal : Runmode {
+ my $self = shift;
+ my %CFG = $self->cfg;
+
+ my ($ul,$ud) = split /\@/, $self->authen->username, 2;
+ my $d = (split /\//, $ENV{PATH_INFO}, 3)[1];
+
+ my $q = $self->query;
+ return $self->redirect($q->url.'/'.$d.'/') if defined $q->param('cancel');
+
+ my $t = $q->param('t') // die "Undefined type";
+ my $error; # Tells whether the change submission has failed.
+ if (defined $q->param('submit')) {
+ # Changes have been submitted: process them
+ my %entry;
+ if ($t eq 'mailbox') {
+ $entry{user} = $q->param('user').'@'.$d;
+ $entry{forwards} = $q->param('forwards');
+ if ($q->param('password') ne $q->param('password2')) {
+ $error = "Passwords do not match";
+ }
+ elsif (length $q->param('password') < $CFG{password_min_length}) {
+ $error = "Password should be at least "
+ .$CFG{password_min_length}
+ ." characters long.";
+ }
+ else {
+ $entry{password} = Fripost::Password::hash($q->param('password'));
+ }
+ # TODO: inherit the quota from the postmaster's?
+ }
+ elsif ($t eq 'alias') {
+ $entry{alias} = $q->param('alias').'@'.$d;
+ $entry{maildrop} = $q->param('maildrop');
+ }
+ elsif ($t eq 'list') {
+ $entry{list} = $q->param('list').'@'.$d;
+ $entry{transport} = $q->param('transport');
+ }
+ else {
+ # Unknown type
+ return $self->redirect($q->url.'/'.$d.'/');
+ }
+ $entry{isactive} = $q->param('isactive');
+ $entry{description} = $q->param('description');
+
+ unless ($error) {
+ my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
+ $error = $fp->$t->add( \%entry, -concat => "(\n|\x{0D}\x{0A})");
+ $fp->done;
+ return $self->redirect($q->url.'/'.$d.'/') unless $error;
+ }
+ }
+
+ my $template = $self->load_tmpl( "add-$t.html", cache => 1, utf8 => 1 );
+ $template->param( url => $self->query->url
+ , user_localpart => $ul
+ , user_domainpart => $ud
+ , domain => $d
+ );
+ if ($error) {
+ # Preserve the (incorrect) form, except the passwords
+ if ($t eq 'mailbox') {
+ $template->param( user => $q->param('user')
+ , forwards => $q->param('forwards') );
+ }
+ elsif ($t eq 'alias') {
+ $template->param( alias => $q->param('alias')
+ , maildrop => $q->param('maildrop') );
+ }
+ elsif ($t eq 'list') {
+ $template->param( list => $q->param('list')
+ , isenc => $q->param('transport') eq 'schleuder' );
+ }
+ else {
+ # Unknown type
+ return $self->redirect($q->url.'/'.$d.'/');
+ }
+ $template->param( isactive => $q->param('isactive')
+ , description => $q->param('description')
+ , error => encode_entities ($error, "‘‘") );
+ }
+ else {
+ $template->param( isactive => 1 );
+ }
+ return $template->output;
+}
+
+
+=head1 AUTHOR
+
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
+=head1 COPYRIGHT
+
+Copyright 2012 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__
diff --git a/lib/Fripost/Panel/Login.pm b/lib/Fripost/Panel/Login.pm
new file mode 100644
index 0000000..8dcfd2b
--- /dev/null
+++ b/lib/Fripost/Panel/Login.pm
@@ -0,0 +1,241 @@
+package Fripost::Panel::Login;
+
+use 5.010_000;
+use strict;
+use warnings;
+use utf8;
+
+=head1 NAME
+
+Login.pm -
+
+=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 Net::LDAP;
+use Authen::SASL;
+use File::Spec::Functions qw/catfile catdir/;
+use HTML::Entities;
+
+
+# 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 ($l,$d) = split /\@/, $u, 2;
+
+ unless (defined $d) {
+ $CFG{default_realm} // return 0;
+ $d = $CFG{default_realm};
+ $u .= '@'.$d;
+ }
+ my $bind_dn = "fvu=$l,fvd=$d,". join (',', @{$CFG{ldap_suffix}});
+
+ my $ldap = Net::LDAP->new( $CFG{ldap_uri} );
+ my $mesg = $ldap->bind ( $bind_dn, password => $p );
+ $ldap->unbind;
+ $mesg->code ? 0 : $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( catdir ( $self->cfg('pwd'), $self->cfg('tmpl_path') ) );
+
+ $self->mode_param( sub {
+ my $self = shift;
+ my $q = $self->query;
+ print STDERR $ENV{PATH_INFO} . '?' . $q->query_string, "\n";
+
+ # 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) = split /\//, $ENV{PATH_INFO};
+
+ return 'ListDomains' unless (defined $null) and $null eq '';
+
+ unless (defined $domain and $domain ne '') {
+ if (defined $a) {
+ return 'AddDomain' if $a eq 'add';
+ }
+ return 'ListDomains';
+ }
+
+ unless (defined $local and $local ne '') {
+ 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 $destination = $self->query->param('destination') //
+ $self->query->url;
+ return $self->redirect($destination);
+}
+
+
+# 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( destination => $self->query->self_url)
+ unless defined $self->query->param('destination');
+
+ 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, utf8 => 1 );
+ $template->param( error => $self->authen->login_attempts );
+ $template->param( destination => $self->query->param('destination') );
+
+ 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($self->query->self_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, utf8 => 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, utf8 => 1 );
+ $template->param( email => $self->cfg('report_email') );
+ $template->param( message => $error );
+ $template->param( url => $self->query->url . '/');
+ return $template->output;
+ }
+}
+
+
+=head1 AUTHOR
+
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
+=head1 COPYRIGHT
+
+Copyright 2012 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__
diff --git a/server.pl b/server.pl
index dc65539..838c7a9 100755
--- a/server.pl
+++ b/server.pl
@@ -6,12 +6,12 @@ use utf8;
use MyServer;
use lib 'lib';
-use FPanel::Interface;
+use Fripost::Panel::Interface;
my $server = MyServer->new();
$server->entry_points({
- '/cgi-bin' => 'FPanel::Interface'
+ '/cgi-bin' => 'Fripost::Panel::Interface'
});
my @config = 'default.in';
--
cgit v1.2.3