package Fripost::Email; use 5.010_000; use strict; use warnings; use utf8; =head1 NAME Email.pm - Send emails =cut our @EXPORT = qw/new_welcome_message new_user_info_message new_alias_info_message subscribe security_status/; our @ISA = qw(Exporter); use FindBin qw($Bin); use lib "$Bin/lib"; use MIME::Entity; use MIME::QuotedPrint; use File::Spec qw/devnull/; use Encode qw/encode/; use Template; use Mail::GnuPG; use GnuPG::Interface; # Create and send an email. sub new { my ($conf, $h) = @_; my $msg = MIME::Entity->build( From => encode('MIME-Q', 'Friposts administratörer') . $conf->{admin_email}, To => $h->{To}, Subject => $h->{Subject}, Encoding => 'quoted-printable', Charset => 'utf-8', Data => $h->{Data} ); my $encrypt_to = $conf->{encrypt_to}; $encrypt_to //= $h->{To}; my $encrypt = 0; $encrypt = 1 unless $conf->{encrypt} eq 'never'; if ($h->{Data} ne '' and (defined $conf->{sign} or $encrypt)) { # To encrypt, the recipient's key has to be in the public # keyring. if ($encrypt) { my $gnupg = GnuPG::Interface->new(); my $res; { # The only way to supress the warning is to desactivate # STDERR. local *STDERR; open *STDERR, '>', File::Spec->devnull() or die "Can't open ".File::Spec->devnull().": $!"; $res = $gnupg->get_public_keys( $encrypt_to ); close *STDERR; } unless ($res) { die "Error: Public key not found for $encrypt_to.\n" if $conf->{encrypt} eq 'secure'; warn "WARN: Public key not found for $encrypt_to. The e-mail will be sent clear.\n"; $encrypt = 0; } } my %gpg; $gpg{use_agent} = 1 if defined $conf->{sign}; $gpg{always_trust} = 1 if $encrypt; $gpg{key} = $conf->{sign} if defined $conf->{sign} and $conf->{sign} ne ''; my $gpg = new Mail::GnuPG( %gpg ); my $ret; if ($encrypt) { if (defined $conf->{sign}) { $ret = $gpg->mime_signencrypt( $msg, $encrypt_to ); } else { $ret = $gpg->mime_encrypt( $msg, $encrypt_to ); } } elsif (defined $conf->{sign}) { $ret = $gpg->mime_sign( $msg ); } if ($ret) { foreach (@{$gpg->{last_message}}) { warn "WARN: $_"; } } } &debug($msg) if $conf->{debug}; return $msg; } sub debug { say STDERR "------------------------------------------------------------------------"; say STDERR decode_qp($_[0]->as_string); say STDERR "------------------------------------------------------------------------"; } # Create a template sub template_create { my ($file, $vars) = @_; my $tt = Template->new({ INCLUDE_PATH => "$Bin/templ", INTERPOLATE => 1, }) || die "$Template::ERROR\n"; my $data; $tt->process($file, $vars, \$data) || die $tt->error(), '\n'; return $data; } sub new_welcome_message { my ($conf, $username) = @_; my $data = &template_create( 'new_user_mail.tt', {} ); return &new ( $conf, { To => $username , Subject => encode('MIME-Q', 'Välkommen till Fripost!') , Data => $data } ); } sub new_user_info_message { my ($conf, $username, $password, $to) = @_; my $data = &template_create( 'user_info.tt' , { user => $username, pass => $password } ); return &new ( $conf, { To => $to , Subject => encode('MIME-Q', 'Välkommen till Fripost!') , Data => $data } ); } sub new_alias_info_message { my ($conf, $goto, $addrs) = @_; my $data = &template_create( 'new_alias.tt' , { addrs => $addrs } ); return &new ( $conf, { To => $goto , Subject => encode('MIME-Q', 'Nya alias till din inkorg'), , Data => $data } ); } # Subscribe the user to the given list eg, 'announce@lists.fripost.org' sub subscribe { my ($conf, $user, $list) = @_; my ($name, $domain) = split /\@/, $list, 2; $list = $name .'-subscribe@' . $domain; my $msg = MIME::Entity->build( From => $user, To => $list, Subject => '', Data => '' ); &debug($msg) if $conf->{debug}; $msg->send(); } # Return the security status of the given MIME entity. Note that this # check is done *after* the possible encryption, hence it cannot detect # Encrypted+Signed emails (they are detected as encrypted only). sub security_status { my $msg = $_[0]; my $gpg = new Mail::GnuPG( ); if ($gpg->is_encrypted ( $msg )) { return 'Encrypted' } else { if ($gpg->is_signed ( $msg )) { return 'Signed' } else { return 'Plain' } } } =head1 AUTHOR Stefan Kangas C<< >> Guilhem Moulin C<< >> =head1 COPYRIGHT Copyright 2010,2011 Stefan Kangas. 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. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. =cut 1; # End of Email.pm __END__