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

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::Schema::Util 'split_addr';
use Fripost::Schema::Password;
use HTML::Entities 'encode_entities';
use URI::Escape::XS 'encodeURIComponent';
use Net::IDN::Encode qw/email_to_unicode email_to_ascii domain_to_ascii/;
use Encode ();


# 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
# visible domains.
sub ListDomains : StartRunmode {
    my $self = shift;
    my %CFG = $self->cfg;

    my $fp = Fripost::Schema::->SASLauth( $self->authen->username, \%CFG );
    my @domains = $fp->domain->search( undef, -sort => 1,
                    -keys => [qw/name isActive isPending description/]);
    my $canIAdd = $fp->domain->domain->canIAdd;
    $fp->done;

    my $template = $self->load_tmpl( 'list-domains.html', cache => 1
                                   , loop_context_vars => 1 );
    $template->param( $self->userInfo );
    $template->param( canIAddDomain => $canIAdd );
    $template->param( domains => [ map { { &fill_HTML_template_from_entry($_)
                                         , URL => &mkURL('.', $_->{name})
                                         , isPending => $_->{isPending} // 0
                                         } }
                                       @domains ] );
    return $template->output;
}



# Add a new (locked) domain.
sub AddDomain : Runmode {
    my $self = shift;
    my %CFG = $self->cfg;

    my $q = $self->query;
    return $self->redirect('./') if defined $q->param('cancel'); # Cancellation

    my $domainname = $q->param('name');
    Encode::_utf8_on($domainname) if defined $domainname;

    my $session_param;
    $session_param = 'AddDomain-Owner-Emails-'.domain_to_ascii($domainname)
        if defined $domainname;

    my $error; # Tells whether the change submission has failed.
    if (defined $q->param('submit')) {
        # Changes have been submitted: process them
        my $fp = Fripost::Schema::->SASLauth( $self->authen->username, \%CFG );

        if (defined $q->param('owner') and defined $session_param) {
            # Ensure that the user didn't spoof the domain ownership.
            my @owners = split "\0", $self->session->param($session_param);
            $error = "‘".$q->param('owner').
                     "’ was not listed among the domain owners"
                unless defined $self->session->param($session_param)
                           and grep { $q->param('owner') eq $_ } @owners;
        }

        $fp->domain->add( &parse_CGI_query ($q)
                        , '-send-confirmation-token' => $q->param('owner') // undef
                        , '-dry-run' => not (defined $q->param('owner'))
                        , -error => \$error
        );
        $fp->done;
    }

    # Confirmation token sent, everything went fine.
    return $self->redirect('./') if !$error and defined $q->param('owner');

    my $tmpl_file;
    my @owners;

    if (!$error and defined $domainname) {
        $tmpl_file = 'add-domain-2.html';
        my @exclude = qw/fripost.org/;
        @owners = Fripost::Schema::Domain::->list_owner_emails
                           ( $domainname, -error => \$error
                           ,'-ignore-MX' => \@exclude );
        undef $tmpl_file if $error;
    }
    # Something went wrong, or the domain is unknown
    $tmpl_file //= 'add-domain-1.html';

    my $template = $self->load_tmpl( $tmpl_file, cache => 1
                                   , loop_context_vars => 1 );
    $template->param( $self->userInfo );
    $template->param( error => encode_entities ($error) ) if $error;
    $template->param( &fill_HTML_template_from_query ($q) );

    if (@owners) {
        # Store the list we font, to ensure the user doesn't send back a
        # spoofed email.
        $self->session->param( $session_param, join("\0", @owners) );
        $self->session->flush;
        $template->param( owners =>
            [ map {{owner => encode_entities $_}} @owners ] )
    }

    return $template->output;
}



# On this page, authenticated users can edit the domain description and
# catch-alls, and toggle activation (if they have the permission).
sub EditDomain : Runmode {
    my $self = shift;
    my %CFG = $self->cfg;

    my $q = $self->query;
    return $self->redirect('./') if defined $q->param('cancel'); # Cancellation

    # Get the domain name from the URL.
    my $domainname = ($self->split_path)[1];
    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
        $fp->domain->replace( &parse_CGI_query ($q, name => $domainname),
                              -error => \$error );
    }

    # We don't want allow edition of pending (locked) domains.
    my $domain = $fp->domain->search( $domainname, -filter => 'unlocked' )
                 // die "404\n";
    $fp->done;

    my $template = $self->load_tmpl( 'edit-domain.html', cache => 1
                                   , loop_context_vars => 1 );
    $template->param( $self->userInfo );
    $template->param( isPostmaster => $domain->{permissions} =~ /p/ );
    if ($error) {
        # Preserve the (incorrect) form
        $template->param( &fill_HTML_template_from_query ($q)
                        , name => encode_entities($domainname)
                        , error => encode_entities ($error) );
    }
    else {
        # Fill the template with what we got from the database.
        $template->param( &fill_HTML_template_from_entry ($domain) );
    }
    $template->param( newChanges => defined $q->param('submit') );
    return $template->output;
}



# On this page, authenticated users can list the virtual users, aliases
# and lists under the current domain.
sub ListLocals : Runmode {
    my $self = shift;
    my %CFG = $self->cfg;

    my $q = $self->query;
    return $self->redirect('./') if defined $q->param('cancel'); # Cancellation

    # Get the domain name from the URL.
    my $domainname = ($self->split_path)[1];
    my $fp = Fripost::Schema::->SASLauth( $self->authen->username, \%CFG );

    if (defined $q->param('unlock')) {
        # Unlock the domain, and come back to the home page.
        # Errors are thrown away.
        $fp->pending->unlock( $domainname, $q->param('unlock'), -error => undef )
            if $q->param('unlock') ne '';
        $fp->done;
        return $self->redirect('../');
    }
    if (defined $q->param('a') and $q->param('a') eq 'delete') {
        # Delete the domain.
        $fp->local->delete($domainname, -error => undef );
        $fp->done;
        return $self->redirect('../');
    }

    # Query *the* matching domain, or 404.
    my $domain = $fp->domain->search( $domainname, -filter => 'unlocked' )
                 // die "404\n";

    # Query the users, aliases and lists under the given domain.
    my @locals = $fp->local->search ( $domainname, sort => 1);
    $fp->done;
    map { $_->{name}= (split_addr $_->{name})[0]; # Remove the domainpart
          $_->{URL} = &mkURL('.', $_->{name})    }# Add a URL
        @locals;

    my @users   = grep { $_->{type} eq 'user' } @locals;
    my @aliases = grep { $_->{type} eq 'alias'} @locals;
    my @lists   = grep { $_->{type} eq 'list' } @locals;

    # Add a link to the list (external) homepage.
    map { $_->{list_URL} = $CFG{'listurl_'.$_->{transport}}.
                           email_to_ascii($_->{name}.'@'.$domainname) }
        @lists;

    my $template = $self->load_tmpl( 'list-locals.html', cache => 1
                                   , loop_context_vars => 1 );

    $template->param( $self->userInfo );
    $template->param( &fill_HTML_template_from_entry ($domain,
                                -loop => ['catchAll'] )
                    , CAodd => not $#aliases % 2 );

    # Can the user edit the domain (change description, toggle
    # activation, modify catch-alls?)
    $template->param( canEditDomain => $domain->{permissions} =~ /[op]/ );

    # Can the user add users?
    $template->param( canAddUser => $domain->{permissions} =~ /p/ );
    # Should we list users?
    $template->param( listUsers => $#users >= 0 ||
                                   $domain->{permissions} =~ /p/ );
    $template->param( users => [
        map { {&fill_HTML_template_from_entry ($_, -loop => ['forward'])} }
            @users ]);

    # Can the user add aliases?
    $template->param( canAddalias => $domain->{permissions} =~ /[aop]/ );
    $template->param( listCanAddAlias => [ map { {item => encode_entities $_} }
                                               @{$domain->{canAddAlias}} ] )
        if $domain->{permissions} =~ /[op]/;
    # Should we list aliases?
    $template->param( listAliases => $#aliases >= 0 ||
                                     $domain->{permissions} =~ /[aop]/ );
    $template->param( aliases => [
        map { {&fill_HTML_template_from_entry ($_, -loop => ['destination'])} }
            @aliases ]);

    # Can the user add lists?
    $template->param( canAddList => $domain->{permissions} =~ /[lop]/ );
    $template->param( listCanAddList => [ map { {item => encode_entities $_} }
                                              @{$domain->{canAddList}} ] )
        if $domain->{permissions} =~ /[op]/;
    # Should we list lists?
    $template->param( listLists => $#lists >= 0 ||
                                   $domain->{permissions} =~ /[lop]/ );
    $template->param( lists => [
        map { { &fill_HTML_template_from_entry ($_, -loop => ['destination'] )
              , isPending => $_->{isPending}
              } }
            @lists ]);
    return $template->output;
}



# In this Run Mode authenticated users can add users, aliases and lists
# (if they have the permission).
sub AddLocal : Runmode {
    my $self = shift;
    my %CFG = $self->cfg;

    my $q = $self->query;
    return $self->redirect('./') if defined $q->param('cancel'); # Cancellation

    # Get the domain name from the URL.
    my $domainname = ($self->split_path)[1];
    my $t = $q->param('t') or return $self->redirect('./');
    return $self->redirect('./') unless grep { $t eq $_ } qw/user alias list/;
    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 $local = &parse_CGI_query($q);
        $local->{type} = $q->param('t');
        $local->{name} = $q->param('name').'@'.$domainname;
        my %rest;

        if ($q->param('password') || $q->param('password2')) {
            if ($q->param('password') ne $q->param('password2')) {
                $error = "Passwords do not match";
            }
            # TODO: ! move that to Password.pm
            elsif (length $q->param('password') < $CFG{password_min_length}) {
                $error = "Password should be at least "
                        .$CFG{password_min_length}
                        ." characters long.";
            }
            else {
                $local->{password} =
                    Fripost::Schema::Password::hash($q->param('password'));
            }
            # TODO: inherit the user quota from the postmaster's?
        }
        # Password needs special care
        $local->{password} = $q->param('password') if $t eq 'list';

        $rest{gpg} = { use_agent => 0
                     , keydir => $CFG{gpghome}
                     , key => $CFG{gpg_private_key_id}
                     , passphrase => $CFG{gpg_private_key_passphrase}
                     };

        unless ($error) {
            my $fp = Fripost::Schema::->SASLauth( $self->authen->username, \%CFG );
            $fp->domain->search ($domainname, -filter => 'unlocked', -count => 1)
                or die "404\n";
            $fp->local->add( $local, %rest, -error => \$error );
            $fp->done;
            return $self->redirect('./') unless $error;
        }
    }

    # Do not send passwords back to the sender.
    $q->delete(qw/password password2/);

    my $template = $self->load_tmpl( "add-$t.html", cache => 1 );
    $template->param( $self->userInfo
                    , domainname => encode_entities($domainname)
                    , &fill_HTML_template_from_query ($q));
    $template->param( transport => [
        map { { item => $_
              , name => ucfirst $_
              , selected => (defined $q->param('transport') and
                             $q->param('transport') eq $_)
            } }
            (keys %Fripost::Schema::Local::list_commands)
        ] )
        if $t eq 'list';
    $template->param( error => encode_entities ($error) ) if $error;
    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 $q = $self->query;
    return $self->redirect('./') if defined $q->param('cancel'); # Cancellation

    # Get the domain name from the URL.
    my ($localname,$domainname) = ($self->split_path)[2,1];
    my $name = $localname.'@'.$domainname;
    my $fp = Fripost::Schema::->SASLauth( $self->authen->username, \%CFG );

    # Search for *the* matching user, alias or list.
    $fp->domain->search ($domainname, -filter => 'unlocked', -count => 1)
        or die "404\n";

    my $error; # Tells whether the change submission has failed.
    if (defined $q->param('a') and $q->param('a') eq 'delete') {
        # Delete the entry
        $fp->local->delete($name, -error => \$error );
        unless ($error) {
            $fp->done;
            return $self->redirect('../');
        }
    }
    my $local = $fp->local->search ($name, -filter => 'unlocked')
        or die "404\n";

    my $t = $local->{type};
    if (defined $q->param('submit')) {
        # Changes have been submitted: process them
        my $local = &parse_CGI_query($q);
        $local->{name} = $name;
        $local->{type} = $t;
        my %rest;

        if ($q->param('password') || $q->param('password2')) {
            if ($q->param('password') ne $q->param('password2')) {
                $error = "Passwords do not match";
            }
            # TODO: ! move that to Password.pm
            # TODO: change password
            elsif (length $q->param('password') < $CFG{password_min_length}) {
                $error = "Password should be at least "
                        .$CFG{password_min_length}
                        ." characters long.";
            }
            else {
                $local->{password} = Fripost::Password::hash($q->param('password'));
            }
        }
        $fp->local->replace($local, -error => \$error);
    }
    $fp->done;

    # Do not send passwords back to the sender.
    $q->delete(qw/password password2/);

    my $template = $self->load_tmpl( "edit-$t.html", cache => 1 );
    $template->param( $self->userInfo
                    , localpart => encode_entities($localname)
                    , domainpart => encode_entities($domainname)
                    , name => encode_entities($name) );
    $template->param( &fill_HTML_template_from_query ($q) );
    my $news = (defined $q->param('submit') or
               (defined $q->param('a') and $q->param('a') eq 'delete'));
    $template->param( newChanges => $news );
    $template->param( error => encode_entities ($error) ) if $error;
    $template->param( canDelete => 1 ) if $t eq 'alias';
    $template->param( list_URL => $CFG{'listurl_'.$local->{transport}}.
                                  email_to_ascii($name) )
        if $t eq 'list';

    $q->delete('a');
    return $template->output;
}




sub mkURL {
    my $host = shift;
    my @path = map { encodeURIComponent($_) } @_;
    join '/', ($host, @path);
}

sub userInfo {
    my $self = shift;
    my ($l,$d) = split_addr( $self->authen->username, -encode => 'unicode' );
    my $root = $ENV{SCRIPT_NAME} // $self->cfg->{'cgi-bin'} // '';
    $root =~ s@/$@@s;

    ( user_localpart  => encode_entities($l)
    , user_domainpart => encode_entities($d)
    , user_URL        => &mkURL ($root, $d, $l)
    )
}


my @single_valued_keys = qw/isActive quota/;
my @multi_valued_keys  = qw/description catchAll
                            canAddAlias canAddList
                            forward destination/;

sub fill_HTML_template_from_entry {
    my $entry = shift;
    my %options = @_;
    my %vars;

    foreach my $key (keys %$entry) {
        next if $options{'-hide'} and
                grep { $key eq $_ } @{$options{'-hide'}};

        if ($key eq 'name') {
            $vars{$key} = encode_entities($entry->{$key});
        }
        elsif (grep {$key eq $_} (qw/URL list_URL transport/,
                                  @single_valued_keys)) {
            $vars{$key} = encode_entities($entry->{$key});
        }
        elsif (grep {$key eq $_} @multi_valued_keys) {
            my @array = map { encode_entities ($_) } @{$entry->{$key}};
            if ($options{'-loop'} and
                grep { $key eq $_ } @{$options{'-loop'}}) {
                $vars{$key} = [ map {{item => $_}} @array ];
            }
            else {
                $vars{$key} = join "\x{0D}\x{0A}", @array;
            }
        }
    }
    return %vars;
}

sub fill_HTML_template_from_query {
    my %params = shift->Vars;
    my %rest = @_;
    my %vars;

    $params{$_} = $rest{$_} for keys %rest;
    foreach my $key (keys %params) {
        next unless defined $params{$key};
        Encode::_utf8_on($params{$key});
        $vars{$key} = encode_entities($params{$key})
            if grep { $key eq $_ } ('name', @single_valued_keys, @multi_valued_keys);
    }
    $vars{isActive} //= 1;
    return %vars;
}

sub parse_CGI_query {
    my %params = shift->Vars;
    my %rest = @_;
    my $entry;

    $params{$_} = $rest{$_} for keys %rest;
    foreach my $key (keys %params) {
        next unless defined $params{$key};
        Encode::_utf8_on($params{$key}) if defined $params{$key};
        if (grep { $key eq $_ } qw/name transport/) {
            $entry->{$key} = $params{$key};
        }
        elsif (grep {$key eq $_} @single_valued_keys) {
            $entry->{$key} = $params{$key};
        }
        elsif (grep {$key eq $_} @multi_valued_keys) {
            $entry->{$key} = $params{$key} ?
                                 [ split "\x{0D}\x{0A}", $params{$key} ] :
                                 [];
            $entry->{$key} = [ grep {$_} @{$entry->{$key}} ];
        }
    }
    $entry->{isActive} //= 1;
    return $entry;
}

=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__