lib/FPanel/ → lib/Fripost/Panel/

2 files changed, 678 insertions, 0 deletions

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__