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::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($_) , URI => &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 , webapp_url => $self->cfg('webapp_url') , tmpl_path => $self->cfg('tmpl_path') , email_from => $self->cfg('email_from') ); $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'; @owners = Fripost::Schema::Domain::->list_owner_emails ( $domainname, -error => \$error ); 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 => $_}} @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; # Get the domain name from the URL. my $domainname = ($self->split_path)[1]; my $q = $self->query; return $self->redirect('./') if defined $q->param('cancel'); # Cancellation 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; } # This Run Mode lists the known users, aliases and lists under the current # domain. sub ListLocals : Runmode { my $self = shift; my %CFG = $self->cfg; my $d = ($self->split_path)[1]; my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG ); my $q = $self->query; if (defined $q->param('unlock')) { my $error; # TODO $fp->domain->unlock( $d, $q->param('unlock'), -error => \$error ) if $q->param('unlock') ne ''; $fp->done; return $self->redirect('../'); } # Query *the* matching domain my %domain = $fp->domain->get( $d, -die => 404 ); # Query the users, 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 @users = $fp->user->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, , loop_context_vars => 1 ); $template->param( $self->userInfo ); $template->param( domain => encode_entities($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 users? $template->param( canAddUser => $domain{permissions} =~ /p/ ); # Should we list users? $template->param( listUsers => $#users >= 0 || $domain{permissions} =~ /p/ ); $template->param( users => [ map { { &mkLink(user => $_->{user}) , description => join ("\n", @{$_->{description}}) , isactive => $_->{isactive} , forwards => [ map { {forward => encode_entities($_)} } @{$_->{forwards}} ] , quota => $_->{quota} }; } @users ]); # Can the user add aliases? $template->param( canAddalias => $domain{permissions} =~ /[aop]/ ); $template->param( listCanAddAlias => [ map { {user => encode_entities($_)} } @{$domain{canAddAlias}} ] ) if $domain{permissions} =~ /[op]/; # Should we list aliases? $template->param( listAliases => $#aliases >= 0 || $domain{permissions} =~ /[aop]/ ); $template->param( aliases => [ map { { &mkLink(alias => $_->{alias}) , description => join ("\n", @{$_->{description}}) , isactive => $_->{isactive} , destinations => [ map { {destination => encode_entities($_)} } @{$_->{maildrop}} ] }; } @aliases ]); $template->param( catchalls => [ map { {catchall => encode_entities($_)} } @{$domain{catchalls}} ] , CAodd => not $#aliases % 2); # Can the user add lists? $template->param( canAddList => $domain{permissions} =~ /[lop]/ ); $template->param( listCanAddList => [ map { {user => encode_entities($_)} } @{$domain{canAddList}} ] ) if $domain{permissions} =~ /[op]/; # Should we list lists? $template->param( listLists => $#lists >= 0 || $domain{permissions} =~ /[lop]/ ); $template->param( lists => [ map { { &mkLink(list => $_->{list}) , description => join ("\n", @{$_->{description}}) , isactive => $_->{isactive} , ispending => $_->{ispending} , transport => $_->{transport} , listURL => $CFG{'listurl_'.$_->{transport}}. email_to_ascii($_->{list}.'@'.$d) }; } @lists ]); 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'); my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG ); # Search for *the* matching user, alias or list. my ($d,$l) = ($self->split_path)[1,2]; $fp->domain->get ($d, -die => 404, -assert_exist => 1); my %local = $fp->local->get ($l.'@'.$d, -die => 404, -concat => "\x{0D}\x{0A}" ); die "Unknown type" unless grep { $local{type} eq $_ } qw/user alias list/; die "404\n" if $local{ispending}; my $error; # Tells whether the change submission has failed. my $t = $local{type}; if (defined $q->param('a') and $q->param('a') eq 'delete') { # Delete the entry $error = $fp->$t->delete($l.'@'.$d, -die => 0); unless ($error) { $fp->done; return $self->redirect('../'); } } if (defined $q->param('submit')) { # Changes have been submitted: process them my %entry; if ($t eq 'user') { $entry{user} = $l.'@'.$d; $entry{forwards} = $q->param('forwards') // undef; 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 { my $u = email_to_unicode($self->authen->username); $fp = Fripost::Schema::->auth( $u, $q->param('oldpw') // '', %CFG, -die => "Wrong password (for ‘".$u."’)." ); }; $error = $@ || $fp->user->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') // undef; } elsif ($t eq 'list') { $entry{list} = $l.'@'.$d; $entry{transport} = $q->param('transport') // undef; } $entry{isactive} = $q->param('isactive') // 1; $entry{description} = $q->param('description') // undef; $error = $fp->$t->replace( \%entry, -concat => "(\n|\x{0D}\x{0A})") unless $error; } my $template = $self->load_tmpl( "edit-$t.html", cache => 1 ); $template->param( $self->userInfo ); $template->param( domain => encode_entities($d) ); if ($error and defined $q->param('submit')) { # Preserve the (incorrect) form, except the passwords if ($t eq 'user') { $template->param( user => encode_entities($l) , forwards => $q->param('forwards') // undef ); } elsif ($t eq 'alias') { $template->param( alias => encode_entities($l) , maildrop => $q->param('maildrop') // undef ); } elsif ($t eq 'list') { $template->param( list => encode_entities($l) ); } $template->param( isactive => $q->param('isactive') // 1 , description => $q->param('description') // undef ); } else { %local = $fp->local->get ($l.'@'.$d, -die => 404, -concat => "\x{0D}\x{0A}" ); if ($t eq 'user') { $template->param( user => encode_entities($local{user}) , forwards => encode_entities($local{forwards}) ); } elsif ($t eq 'alias') { $template->param( alias => encode_entities($local{alias}) , maildrop => encode_entities($local{maildrop}) ); } elsif ($t eq 'list') { $template->param( list => encode_entities($local{list}) ); } $template->param( isactive => $local{isactive} , description => $local{description} ); } $fp->done; 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( listURL => $CFG{'listurl_'.$local{transport}}. email_to_ascii($l.'@'.$d) ) if $t eq 'list'; $q->delete('a'); 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'); my $d = ($self->split_path)[1]; 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; my %rest; if ($t eq 'user') { $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'); 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 { $rest{gpg} = { use_agent => 0 , keydir => $CFG{gpghome} , key => $CFG{gpg_private_key_id} , passphrase => $CFG{gpg_private_key_passphrase} }; $entry{password} = $q->param('password'); } } else { # Unknown type return $self->redirect('./'); } $entry{isactive} = $q->param('isactive') // 1; $entry{description} = $q->param('description') // undef; unless ($error) { my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG ); $fp->domain->get ($d, -die => 404, -assert_exist => 1); $error = $fp->$t->add( \%entry, -concat => "(\n|\x{0D}\x{0A})", %rest); $fp->done; return $self->redirect('./') unless $error; } } my $template = $self->load_tmpl( "add-$t.html", cache => 1 ); $template->param( $self->userInfo ); $template->param( domain => encode_entities($d) ); if ($error) { # Preserve the (incorrect) form, except the passwords if ($t eq 'user') { $template->param( user => $q->param('user') // undef , forwards => $q->param('forwards') // undef ); } elsif ($t eq 'alias') { $template->param( alias => $q->param('alias') // undef , maildrop => $q->param('maildrop') // undef ); } elsif ($t eq 'list') { $template->param( list => $q->param('list') // undef , isenc => $q->param('transport') eq 'schleuder' ); } else { # Unknown type return $self->redirect('./'); } $template->param( isactive => $q->param('isactive') // 1 , description => $q->param('description') // undef , error => encode_entities ($error) ); } else { $template->param( isactive => 1 ); } return $template->output; } sub mkURL { my $host = shift; my @path = map { encodeURIComponent($_) } @_; join '/', ($host, @path); } sub mkLink { my $k = shift; my $d = shift; ( $k => encode_entities($d), $k.'URI' => &mkURL('.', $d) ) } 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) , userURI => &mkURL ($root, $d, $l) ) } sub mkFormContentE { &mkFormContent (map { encode_entities ($_) } @_); } sub mkFormContent { join ("\x{0D}\x{0A}", @_); } sub mkDesc { my $desc = shift // return ''; join '
', map {encode_entities($_)} @$desc; } my @single_valued_keys = qw/isActive/; my @multi_valued_keys = qw/description catchAlls canAddAlias canAddList/; sub fill_HTML_template_from_entry { my $entry = shift; my %vars; foreach my $key (keys %$entry) { if ($key eq 'name') { $vars{$key} = encode_entities($entry->{$key}); } elsif (grep {$key eq $_} @single_valued_keys) { $vars{$key} = $entry->{$key}; } elsif (grep {$key eq $_} @multi_valued_keys) { $vars{$key} = join "\x{0D}\x{0A}", map { encode_entities ($_) } @{$entry->{$key}}; } } return %vars; } sub fill_HTML_template_from_query { my %params = shift->Vars; my %rest = @_; my %vars; $params{$_} = encode_entities ($rest{$_}) for keys %rest; foreach my $key (keys %params) { $vars{$key} = $params{$key} // undef 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) { if ($key eq 'name') { $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<< >> =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__