Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Initial commit on move from customers/ repository

  • Loading branch information...
commit 1cc961e374011e6b93e28002ae293718f3b5d5a3 1 parent c31f5bf
@obra obra authored
Showing with 3,130 additions and 0 deletions.
  1. +37 −0 Changes
  2. +44 −0 MANIFEST
  3. +23 −0 META.yml
  4. +14 −0 Makefile.PL
  5. +51 −0 README
  6. +27 −0 etc/initialdata
  7. +33 −0 html/Callbacks/RT-Crypt-SMIME/User/Prefs.html/FormEnd
  8. +281 −0 inc/Module/Install.pm
  9. +70 −0 inc/Module/Install/Base.pm
  10. +237 −0 inc/Module/Install/Makefile.pm
  11. +336 −0 inc/Module/Install/Metadata.pm
  12. +181 −0 inc/Module/Install/RTx.pm
  13. +287 −0 lib/RT/Crypt/SMIME.pm
  14. +140 −0 lib/RT/Interface/Email/Auth/SMIME.pm
  15. +138 −0 lib/RT/Interface/Email/Auth/StrictSMIME.pm
  16. +51 −0 patches/rt-3.6.3-adjust_mail_plugins_behavior.patch
  17. +28 −0 sign_and_encrypt.pl
  18. +7 −0 t/00.load.t
  19. +16 −0 t/data/README
  20. +36 −0 t/data/simple-txt-enc.eml
  21. +45 −0 t/data/with-bin-attachment.eml
  22. +44 −0 t/data/with-text-attachment.eml
  23. +6 −0 t/pod-coverage.t
  24. +6 −0 t/pod.t
  25. +230 −0 t/smime-incoming.t
  26. +74 −0 t/smime-outgoing.t
  27. +112 −0 testkeys/MailEncrypted.txt
  28. +7 −0 testkeys/MailForSend.txt
  29. +60 −0 testkeys/README
  30. +37 −0 testkeys/ca.crt
  31. +54 −0 testkeys/ca.key
  32. +124 −0 testkeys/recipient.crt
  33. +28 −0 testkeys/recipient.csr
  34. +54 −0 testkeys/recipient.key
  35. +28 −0 testkeys/sender.csr
  36. +38 −0 testkeys/sender@example.com.crt
  37. +54 −0 testkeys/sender@example.com.key
  38. +92 −0 testkeys/sender@example.com.pem
View
37 Changes
@@ -0,0 +1,37 @@
+Revision history for RT-Crypt-SMIME
+
+0.22
+ Use email address from the config if queue has no addresses defined.
+ Use NO_ENCRYPTION flag when sending errors.
+
+0.21
+ Add support for a key per email address.
+
+0.20
+ Fix expiration of a user's attribute we use to cache expiration
+ date of her cert. Now in all cases, even when a key's been updated
+ using API.
+
+0.19
+ Delete user's attribute with expiration date of her key when we
+ update the key.
+
+0.18
+ Use a more generic regexp for detecting smime encrypted messages.
+ Add several new messages for debugging.
+
+0.17
+ We sent messages encrypted without all recipients' keys when there
+ were problems with recipients' keys. So people who have valid keys
+ got messages they can not decrypt. Fix it
+
+0.16
+ Add $NO_ENCRYPTION
+ Use $NO_ENCRYPTION to avoid recursion during errors reporting
+
+0.15
+ Store not encrypted messages in outgoing email records
+
+0.01 - 0.14
+ Initial releases
+
View
44 MANIFEST
@@ -0,0 +1,44 @@
+.cvsignore
+Changes
+etc/initialdata
+html/Callbacks/RT-Crypt-SMIME/User/Prefs.html/FormEnd
+inc/Module/Install.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/RTx.pm
+inc/Module/Install/RTx/Factory.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/RT/Crypt/SMIME.pm
+lib/RT/Interface/Email/Auth/SMIME.pm
+lib/RT/Interface/Email/Auth/StrictSMIME.pm
+Makefile.PL
+MANIFEST
+META.yml # Will be created by "make dist"
+patches/rt-3.6.3-adjust_mail_plugins_behavior.patch
+README
+sign_and_encrypt.pl
+t/00.load.t
+t/data/README
+t/data/simple-txt-enc.eml
+t/data/with-bin-attachment.eml
+t/data/with-text-attachment.eml
+t/pod-coverage.t
+t/pod.t
+t/smime-incoming.t
+t/smime-outgoing.t
+testkeys/ca.crt
+testkeys/ca.key
+testkeys/MailEncrypted.txt
+testkeys/MailForSend.txt
+testkeys/README
+testkeys/recipient.crt
+testkeys/recipient.csr
+testkeys/recipient.key
+testkeys/sender.csr
+testkeys/sender@example.com.crt
+testkeys/sender@example.com.key
+testkeys/sender@example.com.pem
View
23 META.yml
@@ -0,0 +1,23 @@
+---
+abstract: An RT extension to perform S/MIME encryption and decryption for mail RT sends
+author: Jesse Vincent <jesse@bestpractical.com>
+distribution_type: module
+generated_by: Module::Install version 0.67
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
+name: RT-Crypt-SMIME
+no_index:
+ directory:
+ - etc
+ - html
+ - inc
+ - t
+requires:
+ File::Temp: 0
+ Hook::LexWrap: 0
+ IPC::Run3: 0
+ String::ShellQuote: 0
+ Test::More: 0
+version: 0.22
View
14 Makefile.PL
@@ -0,0 +1,14 @@
+use inc::Module::Install;
+
+RTx('RT-Crypt-SMIME');
+author ('Jesse Vincent <jesse@bestpractical.com>');
+version_from ('lib/RT/Crypt/SMIME.pm');
+abstract_from('lib/RT/Crypt/SMIME.pm');
+license('perl');
+requires('Test::More');
+requires('Hook::LexWrap');
+requires('IPC::Run3');
+requires('String::ShellQuote');
+requires('File::Temp');
+
+&WriteAll;
View
51 README
@@ -0,0 +1,51 @@
+RT::Crypt::SMIME(3) User Contributed Perl Documentation RT::Crypt::SMIME(3)
+
+
+
+NNAAMMEE
+ RT::Crypt::SMIME − An RT extension to perform S/MIME encryption and
+ decryption for mail RT sends
+
+SSYYNNOOPPSSIISS
+ # In your RT_SiteConfig.pm, add the following configuration directives
+ use RT::Crypt::SMIME;
+ Set($OpenSSLPath, ’/usr/bin/openssl’); # or wherever openssl lives
+ Set($SMIMEKeys, ’/opt/rt3/etc’); # This directory should contain RT’s private keys and certificates in address.pem files
+ Set($SMIMEPasswords, { address => ’squeamish ossifrage’); # The private passphrases for RT’s private keys
+ @MailPlugins = (qw(Auth::MailFrom Auth::SMIME));
+
+DDEESSCCRRIIPPTTIIOONN
+MMEETTHHOODDSS
+AAUUTTHHOORR
+ Jesse Vincent "<jesse@bestpractical.com>"
+
+LLIICCEENNCCEE AANNDD CCOOPPYYRRIIGGHHTT
+ Copyright (c) 2006, Best Practical Solutions, LLC.
+
+ This module is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself. See perlartistic.
+
+DDIISSCCLLAAIIMMEERR OOFF WWAARRRRAANNTTYY
+ BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+ FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT
+ WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER
+ PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND,
+ EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
+ ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
+ YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
+ NECESSARY SERVICING, REPAIR, OR CORRECTION.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+ WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+ REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE
+ TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CON‐
+ SEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFT‐
+ WARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED
+ INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF
+ THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER
+ OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+
+
+
+perl v5.8.8 2008‐04‐28 RT::Crypt::SMIME(3)
View
27 etc/initialdata
@@ -0,0 +1,27 @@
+@CustomFields = (
+ {
+ Name => 'PublicKey',
+ Type => 'Text',
+ LookupType => 'RT::User',
+ MaxValues => 1,
+ Disabled => 0,
+ Description => 'Public Key',
+ },
+);
+
+@Templates = (
+
+ { Queue => '0',
+ Name => 'NoPublicKey', # loc
+ Description =>
+ 'What RT should send when the user has no defined public key'
+ , # loc
+ Content => q{
+You haven't defined a S/MIME public key in your RT profile yet. Until you do that,
+you will only get mail containing the subject and URL of an RT ticket.
+
+<URL: {$RT::WebURL}Ticket/Display.html?id={$Ticket->id} >
+}
+ },
+
+);
View
33 html/Callbacks/RT-Crypt-SMIME/User/Prefs.html/FormEnd
@@ -0,0 +1,33 @@
+<%args>
+$UserObj => undef
+</%args>
+<%init>
+my $cfs = $UserObj->CustomFields();
+$cfs->Limit(FIELD => 'Name', VALUE => 'PublicKey');
+my $cf = $cfs->First;
+unless ( $cf && $cf->id ) {
+ $RT::Logger->error("Couldn't load 'PublicKey' user's CF");
+ return;
+}
+
+my %request = $m->request_args();
+if (my $content = $request{'SMIME-'.$cf->id. '-Values'}) {
+ $UserObj->DeleteAttribute('SMIMEKeyNotAfter');
+
+ if ($session{'CurrentUser'}->HasRight( Right => 'ModifySelf', Object => $RT::System )
+ and ($content ne $UserObj->FirstCustomFieldValue($cf->id))
+ ) {
+
+ my $u = RT::User->new($RT::SystemUser);
+ $u->Load($session{'CurrentUser'}->id);
+ $u->AddCustomFieldValue(Field => $cf->id, Value => $content);
+
+ }
+}
+
+
+</%init>
+<&|/Widgets/TitleBox, title => 'S/MIME Public Key'&>
+<&/Elements/EditCustomField, Object=> $UserObj, CustomField => $cf, Cols => 80, NamePrefix=> 'SMIME-' &>
+</&>
+
View
281 inc/Module/Install.pm
@@ -0,0 +1,281 @@
+#line 1
+package Module::Install;
+
+# For any maintainers:
+# The load order for Module::Install is a bit magic.
+# It goes something like this...
+#
+# IF ( host has Module::Install installed, creating author mode ) {
+# 1. Makefile.PL calls "use inc::Module::Install"
+# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
+# 3. The installed version of inc::Module::Install loads
+# 4. inc::Module::Install calls "require Module::Install"
+# 5. The ./inc/ version of Module::Install loads
+# } ELSE {
+# 1. Makefile.PL calls "use inc::Module::Install"
+# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
+# 3. The ./inc/ version of Module::Install loads
+# }
+
+use 5.004;
+use strict 'vars';
+
+use vars qw{$VERSION};
+BEGIN {
+ # All Module::Install core packages now require synchronised versions.
+ # This will be used to ensure we don't accidentally load old or
+ # different versions of modules.
+ # This is not enforced yet, but will be some time in the next few
+ # releases once we can make sure it won't clash with custom
+ # Module::Install extensions.
+ $VERSION = '0.68';
+}
+
+# Whether or not inc::Module::Install is actually loaded, the
+# $INC{inc/Module/Install.pm} is what will still get set as long as
+# the caller loaded module this in the documented manner.
+# If not set, the caller may NOT have loaded the bundled version, and thus
+# they may not have a MI version that works with the Makefile.PL. This would
+# result in false errors or unexpected behaviour. And we don't want that.
+my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
+unless ( $INC{$file} ) {
+ die <<"END_DIE";
+Please invoke ${\__PACKAGE__} with:
+
+ use inc::${\__PACKAGE__};
+
+not:
+
+ use ${\__PACKAGE__};
+
+END_DIE
+}
+
+# If the script that is loading Module::Install is from the future,
+# then make will detect this and cause it to re-run over and over
+# again. This is bad. Rather than taking action to touch it (which
+# is unreliable on some platforms and requires write permissions)
+# for now we should catch this and refuse to run.
+if ( -f $0 and (stat($0))[9] > time ) {
+ die << "END_DIE";
+Your installer $0 has a modification time in the future.
+
+This is known to create infinite loops in make.
+
+Please correct this, then run $0 again.
+
+END_DIE
+}
+
+use Cwd ();
+use File::Find ();
+use File::Path ();
+use FindBin;
+
+*inc::Module::Install::VERSION = *VERSION;
+@inc::Module::Install::ISA = __PACKAGE__;
+
+sub autoload {
+ my $self = shift;
+ my $who = $self->_caller;
+ my $cwd = Cwd::cwd();
+ my $sym = "${who}::AUTOLOAD";
+ $sym->{$cwd} = sub {
+ my $pwd = Cwd::cwd();
+ if ( my $code = $sym->{$pwd} ) {
+ # delegate back to parent dirs
+ goto &$code unless $cwd eq $pwd;
+ }
+ $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unshift @_, ($self, $1);
+ goto &{$self->can('call')} unless uc($1) eq $1;
+ };
+}
+
+sub import {
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
+
+ unless ( -f $self->{file} ) {
+ require "$self->{path}/$self->{dispatch}.pm";
+ File::Path::mkpath("$self->{prefix}/$self->{author}");
+ $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
+ $self->{admin}->init;
+ @_ = ($class, _self => $self);
+ goto &{"$self->{name}::import"};
+ }
+
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{"$self->{file}"};
+ delete $INC{"$self->{path}.pm"};
+}
+
+sub preload {
+ my ($self) = @_;
+
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ my $admin = $self->{admin};
+ @exts = $admin->load_all_extensions;
+ }
+
+ my %seen;
+ foreach my $obj ( @exts ) {
+ while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+ next unless $obj->can($method);
+ next if $method =~ /^_/;
+ next if $method eq uc($method);
+ $seen{$method}++;
+ }
+ }
+
+ my $who = $self->_caller;
+ foreach my $name ( sort keys %seen ) {
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
+}
+
+sub new {
+ my ($class, %args) = @_;
+
+ # ignore the prefix on extension modules built from top level.
+ my $base_path = Cwd::abs_path($FindBin::Bin);
+ unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
+ delete $args{prefix};
+ }
+
+ return $args{_self} if $args{_self};
+
+ $args{dispatch} ||= 'Admin';
+ $args{prefix} ||= 'inc';
+ $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
+ $args{bundle} ||= 'inc/BUNDLES';
+ $args{base} ||= $base_path;
+ $class =~ s/^\Q$args{prefix}\E:://;
+ $args{name} ||= $class;
+ $args{version} ||= $class->VERSION;
+ unless ( $args{path} ) {
+ $args{path} = $args{name};
+ $args{path} =~ s!::!/!g;
+ }
+ $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
+
+ bless( \%args, $class );
+}
+
+sub call {
+ my ($self, $method) = @_;
+ my $obj = $self->load($method) or return;
+ splice(@_, 0, 2, $obj);
+ goto &{$obj->can($method)};
+}
+
+sub load {
+ my ($self, $method) = @_;
+
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ ) unless $self->{extensions};
+
+ foreach my $obj (@{$self->{extensions}}) {
+ return $obj if $obj->can($method);
+ }
+
+ my $admin = $self->{admin} or die <<"END_DIE";
+The '$method' method does not exist in the '$self->{prefix}' path!
+Please remove the '$self->{prefix}' directory and run $0 again to load it.
+END_DIE
+
+ my $obj = $admin->load($method, 1);
+ push @{$self->{extensions}}, $obj;
+
+ $obj;
+}
+
+sub load_extensions {
+ my ($self, $path, $top) = @_;
+
+ unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} = delete $INC{$file};
+ push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
+ }
+
+ $self->{extensions} ||= [];
+}
+
+sub find_extensions {
+ my ($self, $path) = @_;
+
+ my @found;
+ File::Find::find( sub {
+ my $file = $File::Find::name;
+ return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
+ my $subpath = $1;
+ return if lc($subpath) eq lc($self->{dispatch});
+
+ $file = "$self->{path}/$subpath.pm";
+ my $pkg = "$self->{name}::$subpath";
+ $pkg =~ s!/!::!g;
+
+ # If we have a mixed-case package name, assume case has been preserved
+ # correctly. Otherwise, root through the file to locate the case-preserved
+ # version of the package name.
+ if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
+ open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
+ my $in_pod = 0;
+ while ( <PKGFILE> ) {
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/); # skip pod text
+ next if /^\s*#/; # and comments
+ if ( m/^\s*package\s+($pkg)\s*;/i ) {
+ $pkg = $1;
+ last;
+ }
+ }
+ close PKGFILE;
+ }
+
+ push @found, [ $file, $pkg ];
+ }, $path ) if -d $path;
+
+ @found;
+}
+
+sub _caller {
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+1;
View
70 inc/Module/Install/Base.pm
@@ -0,0 +1,70 @@
+#line 1
+package Module::Install::Base;
+
+$VERSION = '0.68';
+
+# Suspend handler for "redefined" warnings
+BEGIN {
+ my $w = $SIG{__WARN__};
+ $SIG{__WARN__} = sub { $w };
+}
+
+### This is the ONLY module that shouldn't have strict on
+# use strict;
+
+#line 41
+
+sub new {
+ my ($class, %args) = @_;
+
+ foreach my $method ( qw(call load) ) {
+ *{"$class\::$method"} = sub {
+ shift()->_top->$method(@_);
+ } unless defined &{"$class\::$method"};
+ }
+
+ bless( \%args, $class );
+}
+
+#line 61
+
+sub AUTOLOAD {
+ my $self = shift;
+ local $@;
+ my $autoload = eval { $self->_top->autoload } or return;
+ goto &$autoload;
+}
+
+#line 76
+
+sub _top { $_[0]->{_top} }
+
+#line 89
+
+sub admin {
+ $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+}
+
+sub is_admin {
+ $_[0]->admin->VERSION;
+}
+
+sub DESTROY {}
+
+package Module::Install::Base::FakeAdmin;
+
+my $Fake;
+sub new { $Fake ||= bless(\@_, $_[0]) }
+
+sub AUTOLOAD {}
+
+sub DESTROY {}
+
+# Restore warning handler
+BEGIN {
+ $SIG{__WARN__} = $SIG{__WARN__}->();
+}
+
+1;
+
+#line 138
View
237 inc/Module/Install/Makefile.pm
@@ -0,0 +1,237 @@
+#line 1
+package Module::Install::Makefile;
+
+use strict 'vars';
+use Module::Install::Base;
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.68';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub Makefile { $_[0] }
+
+my %seen = ();
+
+sub prompt {
+ shift;
+
+ # Infinite loop protection
+ my @c = caller();
+ if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
+ die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
+ }
+
+ # In automated testing, always use defaults
+ if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
+ local $ENV{PERL_MM_USE_DEFAULT} = 1;
+ goto &ExtUtils::MakeMaker::prompt;
+ } else {
+ goto &ExtUtils::MakeMaker::prompt;
+ }
+}
+
+sub makemaker_args {
+ my $self = shift;
+ my $args = ($self->{makemaker_args} ||= {});
+ %$args = ( %$args, @_ ) if @_;
+ $args;
+}
+
+# For mm args that take multiple space-seperated args,
+# append an argument to the current list.
+sub makemaker_append {
+ my $self = sShift;
+ my $name = shift;
+ my $args = $self->makemaker_args;
+ $args->{name} = defined $args->{$name}
+ ? join( ' ', $args->{name}, @_ )
+ : join( ' ', @_ );
+}
+
+sub build_subdirs {
+ my $self = shift;
+ my $subdirs = $self->makemaker_args->{DIR} ||= [];
+ for my $subdir (@_) {
+ push @$subdirs, $subdir;
+ }
+}
+
+sub clean_files {
+ my $self = shift;
+ my $clean = $self->makemaker_args->{clean} ||= {};
+ %$clean = (
+ %$clean,
+ FILES => join(' ', grep length, $clean->{FILES}, @_),
+ );
+}
+
+sub realclean_files {
+ my $self = shift;
+ my $realclean = $self->makemaker_args->{realclean} ||= {};
+ %$realclean = (
+ %$realclean,
+ FILES => join(' ', grep length, $realclean->{FILES}, @_),
+ );
+}
+
+sub libs {
+ my $self = shift;
+ my $libs = ref $_[0] ? shift : [ shift ];
+ $self->makemaker_args( LIBS => $libs );
+}
+
+sub inc {
+ my $self = shift;
+ $self->makemaker_args( INC => shift );
+}
+
+my %test_dir = ();
+
+sub _wanted_t {
+ /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
+}
+
+sub tests_recursive {
+ my $self = shift;
+ if ( $self->tests ) {
+ die "tests_recursive will not work if tests are already defined";
+ }
+ my $dir = shift || 't';
+ unless ( -d $dir ) {
+ die "tests_recursive dir '$dir' does not exist";
+ }
+ require File::Find;
+ %test_dir = ();
+ File::Find::find( \&_wanted_t, $dir );
+ $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
+}
+
+sub write {
+ my $self = shift;
+ die "&Makefile->write() takes no arguments\n" if @_;
+
+ my $args = $self->makemaker_args;
+ $args->{DISTNAME} = $self->name;
+ $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
+ $args->{VERSION} = $self->version || $self->determine_VERSION($args);
+ $args->{NAME} =~ s/-/::/g;
+ if ( $self->tests ) {
+ $args->{test} = { TESTS => $self->tests };
+ }
+ if ($] >= 5.005) {
+ $args->{ABSTRACT} = $self->abstract;
+ $args->{AUTHOR} = $self->author;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
+ $args->{NO_META} = 1;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ $args->{SIGN} = 1;
+ }
+ unless ( $self->is_admin ) {
+ delete $args->{SIGN};
+ }
+
+ # merge both kinds of requires into prereq_pm
+ my $prereq = ($args->{PREREQ_PM} ||= {});
+ %$prereq = ( %$prereq,
+ map { @$_ }
+ map { @$_ }
+ grep $_,
+ ($self->build_requires, $self->requires)
+ );
+
+ # merge both kinds of requires into prereq_pm
+ my $subdirs = ($args->{DIR} ||= []);
+ if ($self->bundles) {
+ foreach my $bundle (@{ $self->bundles }) {
+ my ($file, $dir) = @$bundle;
+ push @$subdirs, $dir if -d $dir;
+ delete $prereq->{$file};
+ }
+ }
+
+ if ( my $perl_version = $self->perl_version ) {
+ eval "use $perl_version; 1"
+ or die "ERROR: perl: Version $] is installed, "
+ . "but we need version >= $perl_version";
+ }
+
+ $args->{INSTALLDIRS} = $self->installdirs;
+
+ my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+
+ my $user_preop = delete $args{dist}->{PREOP};
+ if (my $preop = $self->admin->preop($user_preop)) {
+ $args{dist} = $preop;
+ }
+
+ my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
+ $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
+}
+
+sub fix_up_makefile {
+ my $self = shift;
+ my $makefile_name = shift;
+ my $top_class = ref($self->_top) || '';
+ my $top_version = $self->_top->VERSION || '';
+
+ my $preamble = $self->preamble
+ ? "# Preamble by $top_class $top_version\n"
+ . $self->preamble
+ : '';
+ my $postamble = "# Postamble by $top_class $top_version\n"
+ . ($self->postamble || '');
+
+ local *MAKEFILE;
+ open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ my $makefile = do { local $/; <MAKEFILE> };
+ close MAKEFILE or die $!;
+
+ $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
+ $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
+ $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
+ $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
+ $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
+
+ # Module::Install will never be used to build the Core Perl
+ # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
+ # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
+ $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
+ #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
+
+ # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
+ $makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g;
+
+ # XXX - This is currently unused; not sure if it breaks other MM-users
+ # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
+
+ open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ print MAKEFILE "$preamble$makefile$postamble" or die $!;
+ close MAKEFILE or die $!;
+
+ 1;
+}
+
+sub preamble {
+ my ($self, $text) = @_;
+ $self->{preamble} = $text . $self->{preamble} if defined $text;
+ $self->{preamble};
+}
+
+sub postamble {
+ my ($self, $text) = @_;
+ $self->{postamble} ||= $self->admin->postamble;
+ $self->{postamble} .= $text if defined $text;
+ $self->{postamble}
+}
+
+1;
+
+__END__
+
+#line 363
View
336 inc/Module/Install/Metadata.pm
@@ -0,0 +1,336 @@
+#line 1
+package Module::Install::Metadata;
+
+use strict 'vars';
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.68';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+my @scalar_keys = qw{
+ name module_name abstract author version license
+ distribution_type perl_version tests installdirs
+};
+
+my @tuple_keys = qw{
+ build_requires requires recommends bundles
+};
+
+sub Meta { shift }
+sub Meta_ScalarKeys { @scalar_keys }
+sub Meta_TupleKeys { @tuple_keys }
+
+foreach my $key (@scalar_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} if defined wantarray and !@_;
+ $self->{values}{$key} = shift;
+ return $self;
+ };
+}
+
+foreach my $key (@tuple_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} unless @_;
+
+ my @rv;
+ while (@_) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ if ( $module eq 'perl' ) {
+ $version =~ s{^(\d+)\.(\d+)\.(\d+)}
+ {$1 + $2/1_000 + $3/1_000_000}e;
+ $self->perl_version($version);
+ next;
+ }
+ my $rv = [ $module, $version ];
+ push @rv, $rv;
+ }
+ push @{ $self->{values}{$key} }, @rv;
+ @rv;
+ };
+}
+
+# configure_requires is currently a null-op
+sub configure_requires { 1 }
+
+# Aliases for build_requires that will have alternative
+# meanings in some future version of META.yml.
+sub test_requires { shift->build_requires(@_) }
+sub install_requires { shift->build_requires(@_) }
+
+# Aliases for installdirs options
+sub install_as_core { $_[0]->installdirs('perl') }
+sub install_as_cpan { $_[0]->installdirs('site') }
+sub install_as_site { $_[0]->installdirs('site') }
+sub install_as_vendor { $_[0]->installdirs('vendor') }
+
+sub sign {
+ my $self = shift;
+ return $self->{'values'}{'sign'} if defined wantarray and ! @_;
+ $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
+ return $self;
+}
+
+sub dynamic_config {
+ my $self = shift;
+ unless ( @_ ) {
+ warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
+ return $self;
+ }
+ $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
+ return $self;
+}
+
+sub all_from {
+ my ( $self, $file ) = @_;
+
+ unless ( defined($file) ) {
+ my $name = $self->name
+ or die "all_from called with no args without setting name() first";
+ $file = join('/', 'lib', split(/-/, $name)) . '.pm';
+ $file =~ s{.*/}{} unless -e $file;
+ die "all_from: cannot find $file from $name" unless -e $file;
+ }
+
+ $self->version_from($file) unless $self->version;
+ $self->perl_version_from($file) unless $self->perl_version;
+
+ # The remaining probes read from POD sections; if the file
+ # has an accompanying .pod, use that instead
+ my $pod = $file;
+ if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
+ $file = $pod;
+ }
+
+ $self->author_from($file) unless $self->author;
+ $self->license_from($file) unless $self->license;
+ $self->abstract_from($file) unless $self->abstract;
+}
+
+sub provides {
+ my $self = shift;
+ my $provides = ( $self->{values}{provides} ||= {} );
+ %$provides = (%$provides, @_) if @_;
+ return $provides;
+}
+
+sub auto_provides {
+ my $self = shift;
+ return $self unless $self->is_admin;
+
+ unless (-e 'MANIFEST') {
+ warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
+ return $self;
+ }
+
+ # Avoid spurious warnings as we are not checking manifest here.
+
+ local $SIG{__WARN__} = sub {1};
+ require ExtUtils::Manifest;
+ local *ExtUtils::Manifest::manicheck = sub { return };
+
+ require Module::Build;
+ my $build = Module::Build->new(
+ dist_name => $self->name,
+ dist_version => $self->version,
+ license => $self->license,
+ );
+ $self->provides(%{ $build->find_dist_packages || {} });
+}
+
+sub feature {
+ my $self = shift;
+ my $name = shift;
+ my $features = ( $self->{values}{features} ||= [] );
+
+ my $mods;
+
+ if ( @_ == 1 and ref( $_[0] ) ) {
+ # The user used ->feature like ->features by passing in the second
+ # argument as a reference. Accomodate for that.
+ $mods = $_[0];
+ } else {
+ $mods = \@_;
+ }
+
+ my $count = 0;
+ push @$features, (
+ $name => [
+ map {
+ ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
+ : @$_
+ : $_
+ } @$mods
+ ]
+ );
+
+ return @$features;
+}
+
+sub features {
+ my $self = shift;
+ while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
+ $self->feature( $name, @$mods );
+ }
+ return $self->{values}->{features}
+ ? @{ $self->{values}->{features} }
+ : ();
+}
+
+sub no_index {
+ my $self = shift;
+ my $type = shift;
+ push @{ $self->{values}{no_index}{$type} }, @_ if $type;
+ return $self->{values}{no_index};
+}
+
+sub read {
+ my $self = shift;
+ $self->include_deps( 'YAML', 0 );
+
+ require YAML;
+ my $data = YAML::LoadFile('META.yml');
+
+ # Call methods explicitly in case user has already set some values.
+ while ( my ( $key, $value ) = each %$data ) {
+ next unless $self->can($key);
+ if ( ref $value eq 'HASH' ) {
+ while ( my ( $module, $version ) = each %$value ) {
+ $self->can($key)->($self, $module => $version );
+ }
+ }
+ else {
+ $self->can($key)->($self, $value);
+ }
+ }
+ return $self;
+}
+
+sub write {
+ my $self = shift;
+ return $self unless $self->is_admin;
+ $self->admin->write_meta;
+ return $self;
+}
+
+sub version_from {
+ my ( $self, $file ) = @_;
+ require ExtUtils::MM_Unix;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
+}
+
+sub abstract_from {
+ my ( $self, $file ) = @_;
+ require ExtUtils::MM_Unix;
+ $self->abstract(
+ bless(
+ { DISTNAME => $self->name },
+ 'ExtUtils::MM_Unix'
+ )->parse_abstract($file)
+ );
+}
+
+sub _slurp {
+ my ( $self, $file ) = @_;
+
+ local *FH;
+ open FH, "< $file" or die "Cannot open $file.pod: $!";
+ do { local $/; <FH> };
+}
+
+sub perl_version_from {
+ my ( $self, $file ) = @_;
+
+ if (
+ $self->_slurp($file) =~ m/
+ ^
+ use \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ )
+ {
+ my $v = $1;
+ $v =~ s{_}{}g;
+ $self->perl_version($1);
+ }
+ else {
+ warn "Cannot determine perl version info from $file\n";
+ return;
+ }
+}
+
+sub author_from {
+ my ( $self, $file ) = @_;
+ my $content = $self->_slurp($file);
+ if ($content =~ m/
+ =head \d \s+ (?:authors?)\b \s*
+ ([^\n]*)
+ |
+ =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
+ .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
+ ([^\n]*)
+ /ixms) {
+ my $author = $1 || $2;
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ $self->author($author);
+ }
+ else {
+ warn "Cannot determine author info from $file\n";
+ }
+}
+
+sub license_from {
+ my ( $self, $file ) = @_;
+
+ if (
+ $self->_slurp($file) =~ m/
+ (
+ =head \d \s+
+ (?:licen[cs]e|licensing|copyright|legal)\b
+ .*?
+ )
+ (=head\\d.*|=cut.*|)
+ \z
+ /ixms
+ )
+ {
+ my $license_text = $1;
+ my @phrases = (
+ 'under the same (?:terms|license) as perl itself' => 'perl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser public license' => 'gpl', 1,
+ 'BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'proprietary' => 'proprietary', 0,
+ );
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+ $pattern =~ s{\s+}{\\s+}g;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ if ( $osi and $license_text =~ /All rights reserved/i ) {
+ warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
+ }
+ $self->license($license);
+ return 1;
+ }
+ }
+ }
+
+ warn "Cannot determine license info from $file\n";
+ return 'unknown';
+}
+
+1;
View
181 inc/Module/Install/RTx.pm
@@ -0,0 +1,181 @@
+#line 1
+package Module::Install::RTx;
+
+use 5.008;
+use strict;
+use warnings;
+no warnings 'once';
+
+use Module::Install::Base;
+use base 'Module::Install::Base';
+our $VERSION = '0.21';
+
+use FindBin;
+use File::Glob ();
+use File::Basename ();
+
+sub RTx {
+ my ( $self, $name ) = @_;
+
+ my $original_name = $name;
+ my $RTx = 'RTx';
+ $RTx = $1 if $name =~ s/^(\w+)-//;
+ my $fname = $name;
+ $fname =~ s!-!/!g;
+
+ $self->name("$RTx-$name")
+ unless $self->name;
+ $self->all_from( -e "$name.pm" ? "$name.pm" : "lib/$RTx/$fname.pm" )
+ unless $self->version;
+ $self->abstract("RT $name Extension")
+ unless $self->abstract;
+
+ my @prefixes = (qw(/opt /usr/local /home /usr /sw ));
+ my $prefix = $ENV{PREFIX};
+ @ARGV = grep { /PREFIX=(.*)/ ? ( ( $prefix = $1 ), 0 ) : 1 } @ARGV;
+
+ if ($prefix) {
+ $RT::LocalPath = $prefix;
+ $INC{'RT.pm'} = "$RT::LocalPath/lib/RT.pm";
+ } else {
+ local @INC = (
+ @INC,
+ $ENV{RTHOME} ? ( $ENV{RTHOME}, "$ENV{RTHOME}/lib" ) : (),
+ map { ( "$_/rt3/lib", "$_/lib/rt3", "$_/lib" ) } grep $_,
+ @prefixes
+ );
+ until ( eval { require RT; $RT::LocalPath } ) {
+ warn
+ "Cannot find the location of RT.pm that defines \$RT::LocalPath in: @INC\n";
+ $_ = $self->prompt("Path to your RT.pm:") or exit;
+ push @INC, $_, "$_/rt3/lib", "$_/lib/rt3", "$_/lib";
+ }
+ }
+
+ my $lib_path = File::Basename::dirname( $INC{'RT.pm'} );
+ print "Using RT configuration from $INC{'RT.pm'}:\n";
+
+ $RT::LocalVarPath ||= $RT::VarPath;
+ $RT::LocalPoPath ||= $RT::LocalLexiconPath;
+ $RT::LocalHtmlPath ||= $RT::MasonComponentRoot;
+
+ my %path;
+ my $with_subdirs = $ENV{WITH_SUBDIRS};
+ @ARGV = grep { /WITH_SUBDIRS=(.*)/ ? ( ( $with_subdirs = $1 ), 0 ) : 1 }
+ @ARGV;
+
+ my %subdirs;
+ %subdirs = map { $_ => 1 } split( /\s*,\s*/, $with_subdirs )
+ if defined $with_subdirs;
+
+ foreach (qw(bin etc html po sbin var)) {
+ next unless -d "$FindBin::Bin/$_";
+ next if %subdirs and !$subdirs{$_};
+ $self->no_index( directory => $_ );
+
+ no strict 'refs';
+ my $varname = "RT::Local" . ucfirst($_) . "Path";
+ $path{$_} = ${$varname} || "$RT::LocalPath/$_";
+ }
+
+ $path{$_} .= "/$name" for grep $path{$_}, qw(etc po var);
+ $path{lib} = "$RT::LocalPath/lib" unless %subdirs and !$subdirs{'lib'};
+
+ # If we're running on RT 3.8 with plugin support, we really wany
+ # to install libs, mason templates and po files into plugin specific
+ # directories
+ if ($RT::LocalPluginPath) {
+ foreach my $path (qw(lib po html etc bin sbin)) {
+ next unless -d "$FindBin::Bin/$path";
+ next if %subdirs and !$subdirs{$path};
+ $path{$path} = $RT::LocalPluginPath . "/$original_name/$path";
+ }
+ }
+
+ my $args = join( ', ', map "q($_)", %path );
+ print "./$_\t=> $path{$_}\n" for sort keys %path;
+
+ if ( my @dirs = map { ( -D => $_ ) } grep $path{$_}, qw(bin html sbin) ) {
+ my @po = map { ( -o => $_ ) } grep -f,
+ File::Glob::bsd_glob("po/*.po");
+ $self->postamble(<< ".") if @po;
+lexicons ::
+\t\$(NOECHO) \$(PERL) -MLocale::Maketext::Extract::Run=xgettext -e \"xgettext(qw(@dirs @po))\"
+.
+ }
+
+ my $postamble = << ".";
+install ::
+\t\$(NOECHO) \$(PERL) -MExtUtils::Install -e \"install({$args})\"
+.
+
+ if ( $path{var} and -d $RT::MasonDataDir ) {
+ my ( $uid, $gid ) = ( stat($RT::MasonDataDir) )[ 4, 5 ];
+ $postamble .= << ".";
+\t\$(NOECHO) chown -R $uid:$gid $path{var}
+.
+ }
+
+ my %has_etc;
+ if ( File::Glob::bsd_glob("$FindBin::Bin/etc/schema.*") ) {
+
+ # got schema, load factory module
+ $has_etc{schema}++;
+ $self->load('RTxFactory');
+ $self->postamble(<< ".");
+factory ::
+\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name))"
+
+dropdb ::
+\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name drop))"
+
+.
+ }
+ if ( File::Glob::bsd_glob("$FindBin::Bin/etc/acl.*") ) {
+ $has_etc{acl}++;
+ }
+ if ( -e 'etc/initialdata' ) { $has_etc{initialdata}++; }
+
+ $self->postamble("$postamble\n");
+ if ( %subdirs and !$subdirs{'lib'} ) {
+ $self->makemaker_args( PM => { "" => "" }, );
+ } else {
+ $self->makemaker_args( INSTALLSITELIB => "$RT::LocalPath/lib" );
+ }
+
+ $self->makemaker_args( INSTALLSITEMAN1DIR => "$RT::LocalPath/man/man1" );
+ $self->makemaker_args( INSTALLSITEMAN3DIR => "$RT::LocalPath/man/man3" );
+ $self->makemaker_args( INSTALLSITEARCH => "$RT::LocalPath/man" );
+ $self->makemaker_args( INSTALLARCHLIB => "$RT::LocalPath/lib" );
+ if (%has_etc) {
+ $self->load('RTxInitDB');
+ print "For first-time installation, type 'make initdb'.\n";
+ my $initdb = '';
+ $initdb .= <<"." if $has_etc{schema};
+\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(schema))"
+.
+ $initdb .= <<"." if $has_etc{acl};
+\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(acl))"
+.
+ $initdb .= <<"." if $has_etc{initialdata};
+\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(insert))"
+.
+ $self->postamble("initdb ::\n$initdb\n");
+ $self->postamble("initialize-database ::\n$initdb\n");
+ }
+}
+
+sub RTxInit {
+ unshift @INC, substr( delete( $INC{'RT.pm'} ), 0, -5 ) if $INC{'RT.pm'};
+ require RT;
+ RT::LoadConfig();
+ RT::ConnectToDatabase();
+
+ die "Cannot load RT" unless $RT::Handle and $RT::DatabaseType;
+}
+
+1;
+
+__END__
+
+#line 279
View
287 lib/RT/Crypt/SMIME.pm
@@ -0,0 +1,287 @@
+package RT::Crypt::SMIME;
+
+our $VERSION = '0.22';
+
+use warnings;
+use strict;
+use Carp;
+use Hook::LexWrap;
+use IPC::Run3 0.036 'run3';
+use String::ShellQuote 'shell_quote';
+use File::Temp;
+use IO::Handle ();
+
+=head1 NAME
+
+RT::Crypt::SMIME - An RT extension to perform S/MIME encryption and decryption for mail RT sends
+
+
+=head1 SYNOPSIS
+
+ # In your RT_SiteConfig.pm, add the following configuration directives
+ use RT::Crypt::SMIME;
+ Set($OpenSSLPath, '/usr/bin/openssl'); # or wherever openssl lives
+ Set($SMIMEKeys, '/opt/rt3/etc'); # This directory should contain RT's private keys and certificates in address.pem files
+ Set($SMIMEPasswords, { address => 'squeamish ossifrage'); # The private passphrases for RT's private keys
+ @MailPlugins = (qw(Auth::MailFrom Auth::SMIME));
+
+=head1 DESCRIPTION
+
+
+=head1 METHODS
+
+=cut
+
+use RT;
+use RT::Action::SendEmail;
+
+our $NO_ENCRYPTION = 0;
+
+if ( my $real = RT::Interface::Email->can('SendEmail') ) { # 3.7
+ wrap RT::Interface::Email::SendEmail, pre => sub {
+ return if $NO_ENCRYPTION;
+ my (%args) = (
+ Entity => undef,
+ Bounce => 0,
+ Ticket => undef,
+ Transaction => undef,
+ splice( @_, 0, $#_ ),
+ );
+ my $mime = $args{Entity};
+
+ my $mime_copy = encrypt_message( $args{Ticket}, $mime->dup );
+
+ $_[-1] = $real->( %args, $mime_copy ? ( Entity => $mime_copy ) : () );
+ };
+}
+else { # 3.6
+ wrap RT::Action::SendEmail::OutputMIMEObject, pre => sub {
+ return if $NO_ENCRYPTION;
+ my $self = $_[0];
+ my $mime = $_[1];
+ my $mime_copy = encrypt_message( $self->TicketObj, $mime->dup );
+ $_[1] = $mime_copy if $mime_copy;
+ };
+}
+
+sub encrypt_message {
+ my $ticket = shift;
+ my $mime_obj = shift;
+ my ($addr) = map { $_->address } Mail::Address->parse( $mime_obj->head->get('From') );
+
+ # extract recipients from each header
+ my %headers;
+ foreach my $header (qw(To Cc Bcc)) {
+ @{ $headers{$header} } = map { $_->address }
+ Mail::Address->parse( $mime_obj->head->get($header) );
+ }
+
+ my @keys;
+ foreach my $header ( keys %headers ) {
+ # Splice all addresses from a list and then add them back if everything is fine
+ foreach my $addr ( splice @{ $headers{$header} } ) {
+ chomp $addr;
+ $RT::Logger->debug( "Considering encrypting message to " . $addr );
+ my $user = RT::User->new( $RT::SystemUser );
+ $user->LoadByEmail( $addr );
+ my $key;
+ $key = $user->FirstCustomFieldValue('PublicKey') if ( $user->id );
+ unless ( $key ) {
+ $RT::Logger->error(
+ "Trying to send an encrypted message to " . $addr
+ .", but we couldn't find a public key or user object for them"
+ );
+
+ # send the user a special message template that contains
+ # only a URL and the note that their key isn't set up
+ send_message( $ticket, $addr, 'NoPublicKey' );
+ next;
+ }
+
+ my $expire = get_expiration( $user );
+ unless ( $expire ) {
+ # we continue here as it's most probably a problem with the key,
+ # so later during encryption we'll get verbose errors
+ $RT::Logger->error(
+ "Trying to send an encrypted message to ". $addr
+ .", but we couldn't get expiration date of the key."
+ );
+ }
+ elsif ( $expire->Diff( time ) < 0 ) {
+ $RT::Logger->error(
+ "Trying to send an encrypted message to " . $addr
+ .", but the key is expired"
+ );
+ send_message( $ticket, $addr, 'ExpiredPublicKey' );
+ next;
+ }
+
+ $RT::Logger->debug( "Encrypting to " . $addr );
+
+ my $user_crt = File::Temp->new;
+ print $user_crt $key;
+
+ push @keys, $user_crt;
+ push @{ $headers{ $header } }, $addr;
+ }
+ }
+
+ foreach my $header ( keys %headers ) {
+ $mime_obj->head->replace( $header,
+ join( ', ', @{ $headers{$header} } ) );
+ }
+ return unless @keys;
+
+ $mime_obj->make_multipart('mixed', Force => 1);
+ my ($buf, $err) = ('', '');
+ {
+ local $ENV{SMIME_PASS} = $RT::SMIMEPasswords->{$addr};
+ safe_run3(
+ join(
+ ' ',
+ shell_quote(
+ $RT::OpenSSLPath,
+ qw( smime -sign -passin env:SMIME_PASS),
+ -signer => $RT::SMIMEKeys.'/'.$addr.'.pem',
+ -inkey => $RT::SMIMEKeys.'/'.$addr.'.pem',
+ ),
+ '|',
+ shell_quote(
+ qw(openssl smime -encrypt -des3),
+ map { $_->filename } @keys
+ )
+ ),
+ \$mime_obj->parts(0)->stringify,
+ \$buf, \$err
+ );
+ }
+ $RT::Logger->debug( "openssl stderr: " . $err ) if length $err;
+
+ my $tmpdir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
+ my $parser = MIME::Parser->new();
+ $parser->output_dir($tmpdir);
+ my $newmime = $parser->parse_data($buf);
+ $mime_obj->parts([$newmime]);
+ $mime_obj->make_singlepart;
+ return $mime_obj;
+
+}
+
+sub safe_run3 {
+ # We need to reopen stdout temporarily, because in FCGI
+ # environment, stdout is tied to FCGI::Stream, and the child
+ # of the run3 wouldn't be able to reopen STDOUT properly.
+ my $stdout = IO::Handle->new;
+ $stdout->fdopen( 1, 'w' );
+ local *STDOUT = $stdout;
+
+ my $stderr = IO::Handle->new;
+ $stderr->fdopen( 2, 'w' );
+ local *STDERR = $stderr;
+
+ local $SIG{'CHLD'} = 'DEFAULT';
+ run3(@_);
+}
+
+sub send_message {
+ my ($ticket, $to, $template_name) = (@_);
+
+ my $template = RT::Template->new( $RT::SystemUser );
+ $template->LoadGlobalTemplate( $template_name );
+ unless ( $template->id ) {
+ $RT::Logger->error( "Couldn't load template '$template_name'");
+ return;
+ }
+ $template->Parse( TicketObj => $ticket );
+ my $sorry_dude = $template->MIMEObj;
+ $sorry_dude->head->set( To => $to );
+
+ local $NO_ENCRYPTION = 1;
+ return RT::Interface::Email->can('SendEmail')
+ ? RT::Interface::Email::SendEmail( Entity => $sorry_dude )
+ : RT::Action::SendEmail->OutputMIMEObject($sorry_dude);
+}
+
+sub get_expiration {
+ my $user = shift;
+
+ my $key_obj = $user->CustomFieldValues('PublicKey')->First;
+ unless ( $key_obj ) {
+ $RT::Logger->warn('User #'. $user->id .' has no SMIME key');
+ return;
+ }
+
+ my $attr = $user->FirstAttribute('SMIMEKeyNotAfter');
+ if ( $attr and my $date_str = $attr->Content
+ and $key_obj->LastUpdatedObj->Unix < $attr->LastUpdatedObj->Unix )
+ {
+ my $date = RT::Date->new( $RT::SystemUser );
+ $date->Set( Format => 'unknown', Value => $attr->Content );
+ return $date;
+ }
+ $RT::Logger->debug('Expiration date of SMIME key is not up to date');
+
+ my $key = $key_obj->Content;
+ my ($buf, $err) = ('', '');
+ {
+ local $ENV{SMIME_PASS} = '123456';
+ safe_run3(
+ join( ' ', shell_quote( $RT::OpenSSLPath, qw(x509 -noout -dates) ) ),
+ \$key, \$buf, \$err
+ );
+ }
+ $RT::Logger->debug( "openssl stderr: " . $err ) if length $err;
+
+ my ($date_str) = ($buf =~ /^notAfter=(.*)$/m);
+ return unless $date_str;
+
+ $RT::Logger->debug( "smime key expiration date is $date_str" );
+ $user->SetAttribute(
+ Name => 'SMIMEKeyNotAfter',
+ Description => 'SMIME key expiration date',
+ Content => $date_str,
+ );
+ my $date = RT::Date->new( $RT::SystemUser );
+ $date->Set( Format => 'unknown', Value => $date_str );
+ return $date;
+}
+
+=head1 AUTHOR
+
+Jesse Vincent C<< <jesse@bestpractical.com> >>
+
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2006, Best Practical Solutions, LLC.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+
+=head1 DISCLAIMER OF WARRANTY
+
+BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
+EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
+ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
+YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
+NECESSARY SERVICING, REPAIR, OR CORRECTION.
+
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
+LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
+OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
+THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+=cut
+
+1;
View
140 lib/RT/Interface/Email/Auth/SMIME.pm
@@ -0,0 +1,140 @@
+package RT::Interface::Email::Auth::SMIME;
+
+use warnings;
+use strict;
+
+use RT::Crypt::SMIME;
+use String::ShellQuote 'shell_quote';
+
+use File::Temp qw/ tempfile /;
+
+=head1 NAME
+
+RT::Interface::Email::Auth::SMIME
+
+=head1 DESCRIPTION
+
+=head2 GetCurrentUser
+
+Returns a CurrentUser object. Also performs all the commands.
+
+=cut
+
+sub GetCurrentUser {
+ my %args = (
+ Message => undef,
+ RawMessageRef => undef,
+ CurrentUser => undef,
+ AuthLevel => undef,
+ Action => undef,
+ Ticket => undef,
+ Queue => undef,
+ @_
+ );
+
+
+ my $msg = $args{'Message'};
+ my $msgref = $args{'RawMessageRef'};
+ $RT::Logger->debug('dealing... '.$msg->head->get('Content-type'));
+
+ $RT::Logger->debug( "mime type: " .$msg->head->mime_type );
+ if ($msg->head->mime_type =~ /pkcs7-mime/i) {
+ $msg->head->set('X-RT-Privacy', 'SMIME');
+ my $addr = $args{Action} eq 'correspond'
+ ? $args{Queue}->CorrespondAddress || $RT::CorrespondAddress
+ : $args{Queue}->CommentAddress || $RT::CommentAddress
+ ;
+
+ decrypt($msg, $msgref, $addr);
+ }
+ else {
+ $msg->head->set('X-RT-Incoming-Encryption', 'Not encrypted')
+ unless $msg->head->get('X-RT-Incoming-Encryption');
+ }
+ return ($args{'CurrentUser'}, $args{'AuthLevel'});
+
+}
+
+
+sub decrypt {
+ my $msg = shift;
+ my $msgref = shift;
+ my $addr = shift;
+
+ if ( $msg->is_multipart ) {
+ $msg->head->set('X-RT-Incoming-Encryption', 'Failed');
+ $RT::Logger->crit('S/MIME entity is mutipart');
+ return;
+ }
+
+ my ($buf, $err);
+ {
+ local $ENV{SMIME_PASS} = $RT::SMIMEPasswords->{$addr};
+ local $SIG{CHLD} = 'DEFAULT';
+ RT::Crypt::SMIME::safe_run3(
+ shell_quote(
+ $RT::OpenSSLPath,
+ qw(smime -decrypt -passin env:SMIME_PASS),
+ -recip => $RT::SMIMEKeys.'/'.$addr.'.pem',
+ ),
+ $msgref,
+ \$buf,
+ \$err
+ );
+ }
+ $RT::Logger->debug( "openssl stderr: " . $err ) if length $err;
+ $RT::Logger->debug("decrypted.... ($buf)");
+
+ # XXX: verify sender signature in detach and nodetach mode.
+
+ my $rtparser = _extract_msg_from_buf(\$buf);
+ my $decrypted = $rtparser->Entity;
+
+ if ($decrypted->head->mime_type =~ /pkcs7-mime/i) {
+ $RT::Logger->debug('nodetach mode signature found');
+ $buf = ''; $err = '';
+ RT::Crypt::SMIME::safe_run3(
+ shell_quote(
+ $RT::OpenSSLPath,
+ qw(smime -verify -noverify)
+ ),
+ \$decrypted->as_string,
+ \$buf,
+ \$err
+ );
+
+ $RT::Logger->debug( "openssl stderr: " . $err ) if length $err;
+ $rtparser = _extract_msg_from_buf(\$buf);
+ $decrypted = $rtparser->Entity;
+ }
+
+ $rtparser->{'AttachmentDirs'} = ();
+ $msg->head->set('X-RT-Incoming-Encryption', 'Success');
+ $msg->make_multipart('mixed');
+ $msg->parts([]);
+ $msg->add_part( $decrypted );
+ $msg->make_singlepart;
+}
+
+sub _extract_msg_from_buf {
+ my $buf = shift;
+ my $rtparser = RT::EmailParser->new();
+ my $parser = MIME::Parser->new();
+ $rtparser->_SetupMIMEParser($parser);
+ $parser->output_to_core(0);
+ unless ( $rtparser->{'entity'} = $parser->parse_data($$buf) ) {
+ $RT::Logger->crit(
+ "Couldn't parse MIME stream and extract the submessages");
+
+ # Try again, this time without extracting nested messages
+ $parser->extract_nested_messages(0);
+ unless ( $rtparser->{'entity'} = $parser->parse_data($$buf) ) {
+ $RT::Logger->crit("couldn't parse MIME stream");
+ return (undef);
+ }
+ }
+ $rtparser->_PostProcessNewEntity;
+ return $rtparser;
+}
+
+1;
View
138 lib/RT/Interface/Email/Auth/StrictSMIME.pm
@@ -0,0 +1,138 @@
+package RT::Interface::Email::Auth::StrictSMIME;
+
+use warnings;
+use strict;
+
+use RT::Crypt::SMIME ();
+use RT::Action::SendEmail ();
+use RT::Interface::Email qw(ParseSenderAddressFromHead);
+
+=head1 NAME
+
+RT::Interface::Email::Auth::StrictSMIME - strict SMIME protection
+
+=head1 DESCRIPTION
+
+If message is not encrypted with SMIME standard then report error to
+sender and doesn't create or update ticket.
+
+=head1 CONFIGURATION
+
+Add this filter after standard RT's one and before any other.
+Configuration should be something like the following:
+
+ @MailPlugins = (qw(Auth::MailFrom Auth::StrictSMIME Auth::SMIME));
+
+As well you need template 'NotEncryptedMessage', this template is used
+to notify senders that their message was not recorded. When the template
+is called an object of the current ticket may be not available so you
+have to avoid any code in the template that doesn't check this fact. Use
+conditions C<if ( $TicketObj && $TicketObj->id ) {...}>. In general
+situation next template should work just fine:
+
+ Subject: [ERROR] Couldn't process a message
+
+ Hi, message you sent was not processed as it was not encrypted with
+ SMIME encryption. Please, resubmit your request using encryption
+ facility.
+
+=head1 CAVEATS
+
+This plugin should work normal with RT 3.6.3, but this version of RT
+has a little bit broken logic, so you may see undesirable side effects
+and probably wrong results. To fix issues we provide a patch you can
+find in patches dir within the tarball, changes in the patch are in the
+RT's repository and would be available with RT 3.6.4.
+
+=head1 METHODS
+
+=head2 GetCurrentUser
+
+Returns a CurrentUser object. Also performs all the commands.
+
+=cut
+
+sub GetCurrentUser {
+ my %args = (
+ Message => undef,
+ RawMessageRef => undef,
+ CurrentUser => undef,
+ AuthLevel => undef,
+ Action => undef,
+ Ticket => undef,
+ Queue => undef,
+ @_
+ );
+
+ return ($args{'CurrentUser'}, $args{'AuthLevel'})
+ if $args{'Action'} && $args{'Action'} ne 'comment'
+ && $args{'Action'} ne 'correspond';
+
+ return ($args{'CurrentUser'}, $args{'AuthLevel'})
+ if IsEncrypted( $args{'Message'} );
+
+ $RT::Logger->info( 'Message is not encrypted, sending error' );
+
+ my $template = RT::Template->new( $RT::SystemUser );
+ $template->LoadGlobalTemplate('NotEncryptedMessage');
+ unless ( $template->id ) {
+ $RT::Logger->crit( "Couldn't load template 'NotEncryptedMessage'");
+ return ($args{'CurrentUser'}, $args{'AuthLevel'});
+ }
+ $template->Parse( TicketObj => $args{'Ticket'} );
+
+ my $error_msg = $template->MIMEObj;
+ my $sender = (ParseSenderAddressFromHead( $args{'Message'}->head ))[0];
+ $error_msg->head->set( To => $sender );
+
+ local $RT::Crypt::SMIME::NO_ENCRYPTION = 1;
+ RT::Interface::Email->can('SendEmail')
+ ? RT::Interface::Email::SendEmail( Entity => $error_msg )
+ : RT::Action::SendEmail->OutputMIMEObject( $error_msg );
+
+ return ($args{'CurrentUser'}, -2);
+}
+
+sub IsEncrypted {
+ my $msg = shift;
+
+ # RFC3851 Ch. 3.9. Identifying an S/MIME Message
+ my $fname = $msg->head->recommended_filename;
+
+ # RFC3851 defines 'application/pkcs7-mime' only, however some clients
+ # use 'application/x-pkcs7-mime' type, so we use more generic regexp
+ my $type = lc $msg->head->mime_type;
+ if ( $type =~ /pkcs7-mime/ ) {
+ $RT::Logger->debug('smime message, detected by mime type');
+ unless ( $fname ) {
+ $RT::Logger->debug('[passed] no file name');
+ return 1;
+ }
+ $RT::Logger->debug('file name is '. $fname);
+ if ( lc substr($fname, -3) eq 'p7m' ) {
+ $RT::Logger->debug('[passed] file name has extension p7m');
+ return 1;
+ }
+ $RT::Logger->debug('[denied] file name has incorrect name');
+ return 0;
+ }
+ elsif ( $type eq 'application/octet-stream' ) {
+ unless ( $fname ) {
+ $RT::Logger->debug('[denied] octet-stream type, but not a named file');
+ return 0;
+ } elsif ( lc substr($fname, -3) eq 'p7m' ) {
+ $RT::Logger->debug('[passed] detected by octet-stream type and file ext');
+ return 1;
+ } else {
+ $RT::Logger->debug("[denied] octet-stream type, but file's ext is not *.p7m");
+ return 0;
+ }
+ }
+ else {
+ $RT::Logger->debug("[denied] '$type' is not correct");
+ return 0;
+ }
+ return 0;
+}
+
+1;
View
51 patches/rt-3.6.3-adjust_mail_plugins_behavior.patch
@@ -0,0 +1,51 @@
+----------------------------------------------------------------------
+r4425 (orig r6789): ruz | 2007-01-21 07:50:29 +0300
+
+* that was wrong idea to run next mail plugins for some action
+ if the current plugin said that everything was done (returned
+ status -2).
+----------------------------------------------------------------------
+=== lib/RT/Interface/Email.pm
+==================================================================
+--- lib/RT/Interface/Email.pm (revision 4424)
++++ lib/RT/Interface/Email.pm (revision 4425)
+@@ -645,6 +645,10 @@
+ $skip_action{$action}++ if $AuthStat == -2;
+ }
+
++ # strip actions we should skip
++ @actions = grep !$skip_action{$_}, @actions if $AuthStat == -2;
++ last unless @actions;
++
+ last if $AuthStat == -1;
+ }
+ # {{{ If authentication fails and no new user was created, get out.
+@@ -694,9 +698,6 @@
+ return ( 0, $result, undef );
+ }
+
+- # strip actions we should skip
+- @actions = grep !$skip_action{$_}, @actions;
+-
+ # if plugin's updated SystemTicket then update arguments
+ $args{'ticket'} = $SystemTicket->Id if $SystemTicket && $SystemTicket->Id;
+
+@@ -738,7 +739,7 @@
+ @actions = grep !/^(comment|correspond)$/, @actions;
+ $args{'ticket'} = $id;
+
+- } else {
++ } elsif ( $args{'ticket'} ) {
+
+ $Ticket->Load( $args{'ticket'} );
+ unless ( $Ticket->Id ) {
+@@ -752,6 +753,9 @@
+
+ return ( 0, $error );
+ }
++ $args{'ticket'} = $Ticket->id;
++ } else {
++ return ( 1, "Success", $Ticket );
+ }
+
+ # }}}
View
28 sign_and_encrypt.pl
@@ -0,0 +1,28 @@
+use IPC::Run3 'run3';
+use String::ShellQuote 'shell_quote';
+use File::Temp;
+
+my $signer = 'testkeys/sender';
+my $out = File::Temp->new;
+{
+ local $ENV{SMIME_PASS} = '123456';
+ run3( join( ' ',
+ shell_quote(
+ qw(openssl smime -sign -passin env:SMIME_PASS -text),
+ -signer => $signer . '.crt',
+ -inkey => $signer . '.key'
+ ),
+ '|',
+ shell_quote(
+ qw(openssl smime -encrypt -des3),
+ -from => 'steve@openssl.org',
+ -to => 'someone@somewhere',
+ -subject => "Signed and Encrypted message",
+ 'testkeys/recipient.crt'
+ )
+ ),
+ \'orzzzzzz',
+ \*STDOUT,
+ \*STDERR
+ );
+}
View
7 t/00.load.t
@@ -0,0 +1,7 @@
+use Test::More tests => 1;
+
+BEGIN {
+use_ok( 'RT::Crypt::SMIME' );
+}
+
+diag( "Testing RT::Crypt::SMIME $RT::Crypt::SMIME::VERSION" );
View
16 t/data/README
@@ -0,0 +1,16 @@
+Files with MIME entities generated and encryted with testkeys/sender.crt
+in real MUA(look into files for User-Agent)
+
+* simple-txt-enc.eml
+ simple plain/text message with 'test' content
+
+* with-text-attachment.eml
+ multipart message with a text part and a text attachment.
+ Content of the text is 'test'. Name of the attachment
+ is 'attachment.txt' and content is 'text attachment'.
+
+* with-bin-attachment.eml
+ multipart message with a text part and a binary attachment.
+ Content of the text is 'test'. Name of the attachment
+ is 'attachment.bin' and content is 32 random bytes.
+
View
36 t/data/simple-txt-enc.eml
@@ -0,0 +1,36 @@
+Date: Fri, 22 Dec 2006 05:01:04 +0300
+From: root@localhost
+X-Mozilla-Draft-Info: internal/draft; vcard=0; receipt=0; uuencode=0
+User-Agent: Thunderbird 1.5.0.9 (X11/20061221)
+MIME-Version: 1.0
+To: sender@test.com
+Subject: test
+Content-Type: application/x-pkcs7-mime; name="smime.p7m"
+Content-Transfer-Encoding: base64
+Content-Disposition: attachment; filename="smime.p7m"
+Content-Description: S/MIME Encrypted Message
+
+MIAGCSqGSIb3DQEHA6CAMIACAQAxggQ8MIIBjgIBADB2MGIxCzAJBgNVBAYTAlpBMSUwIwYD
+VQQKExxUaGF3dGUgQ29uc3VsdGluZyAoUHR5KSBMdGQuMSwwKgYDVQQDEyNUaGF3dGUgUGVy
+c29uYWwgRnJlZW1haWwgSXNzdWluZyBDQQIQBgzQJigV55Om1dc1u4CuYzANBgkqhkiG9w0B
+AQEFAASCAQBEI9JKBQgIqLcRTiYCwDHR1dVTnlOoAAVHoM10dHxzszYBNV5GBnQgPVzV5EbU
+kkjKPJy1Ipv6Eixoqed2u54/68fmvGSEC+zH8nu7noMbvF7nuspPfwawf9GQNq3jt3qZRuuk
+Us2EB5GGz8p9gxgFnv/GtrUQ+7HxCVvJRwFuyXkqwfqo2kxnE4C1jS05xjZ3ioo5gQlncC5f
+ib63YtU6Gvlnh9zq/LV0bMUg6SygRNAHoO+BTKBBHlzNMg0ixUESzRmxF1hJA3rbhCx4xPfe
+OHZh6NtSHPSD+88nzK3qBv1Gosz9In6O5/aYreQgLT6Vrbb+jlCPs3BJGaRPNwVKMIICpgIB
+ADCBjTCBhzELMAkGA1UEBhMCUlUxEzARBgNVBAgTClNvbWUtU3RhdGUxFjAUBgNVBAcTDVN0
+LVBldGVyc2J1cmcxDTALBgNVBAoTBFRlc3QxDTALBgNVBAsTBHRlc3QxDzANBgNVBAMTBlRl
+c3RlcjEcMBoGCSqGSIb3DQEJARYNdGVzdEB0ZXN0LmNvbQIBAzANBgkqhkiG9w0BAQEFAASC
+AgAqLoqQoTHSNgSyp+8XuylkokpE8/zE8mQ0TVnVrP8LrK8ppxBAkVr8/GGG2BNtwKXJEaEP
+7cDoHYABQS4xQD3CrEBtq180rDR0yGunRYuCTlBrAAZWy8Nq3/KGbwxJJBaqHUomaqiRUeiD
+j+V42pU1hVhBVUR+dNlDrtnLyh1OhbR1/ddhU0WCioAAdbyVCntgyHQU0Sr55xVINP69RUte
+OCHQj+s5b6HnfN2pQjdjZf5pHJdCajO5IpKn68LaBY2Q0YZVZYs3PLnRe0yHpZvHa7T5KRNs
+XL4fkJ5n6wrP48UH2eHyopHCww28qZupbnSkhZCERa7mJ3niExaRxnZnS28IpaU4AlbMLZGu
+fz7woFxcxrcwkGeGXCTxZkj6UkXXFZK/s04iWoQdcN59A56yGc0RTHg29AHQshJ2d3Ydcm+N
+/Uv9OwSkDOG/V6f6BvmWjBldF6SI2sOmEEK+SQy0OC81TYJfqVHRfT0lyUfz43JGGwOhgb1j
+hyxBgugzGq2+KkIdyONMdBZXe4HuZOm4MStB/5NOdb1lPttB5zgkcdq9I/rVl+QRSh3wjZWf
+2JL9HvlljweVNbVoCiwQjm17u14PnNlW0797YTXizHlsLUpupMgI8N2eDKv53cKTGyT/z+yc
+AmqCYdph3oA7VWlXBvQbZUeDxOarpfTnq+aOEjCABgkqhkiG9w0BBwEwFAYIKoZIhvcNAwcE
+CBUAZSknCBIhoIAEYHg/qMyTJn4qoHtG5PnCve9BA5m+02B8RFLe1EQ/4+S3r2tP8jSvCPvk
+jMrzK7wrza2xlXaOisFvakPMyjTqwCkup55n3LDELbXMe3eFt62L7mWSD1HI+bwCEM2d7v/5
+DAQIbHw1VJzs8tsAAAAAAAAAAAAA
View
45 t/data/with-bin-attachment.eml
@@ -0,0 +1,45 @@
+Date: Fri, 22 Dec 2006 06:41:22 +0300
+From: root@localhost
+X-Mozilla-Draft-Info: internal/draft; vcard=0; receipt=0; uuencode=0
+User-Agent: Thunderbird 1.5.0.9 (X11/20061221)
+MIME-Version: 1.0
+To: sender@test.com
+Subject: test
+Content-Type: application/x-pkcs7-mime; name="smime.p7m"
+Content-Transfer-Encoding: base64
+Content-Disposition: attachment; filename="smime.p7m"
+Content-Description: S/MIME Encrypted Message
+
+MIAGCSqGSIb3DQEHA6CAMIACAQAxggQ8MIIBjgIBADB2MGIxCzAJBgNVBAYTAlpBMSUwIwYD
+VQQKExxUaGF3dGUgQ29uc3VsdGluZyAoUHR5KSBMdGQuMSwwKgYDVQQDEyNUaGF3dGUgUGVy
+c29uYWwgRnJlZW1haWwgSXNzdWluZyBDQQIQBgzQJigV55Om1dc1u4CuYzANBgkqhkiG9w0B
+AQEFAASCAQC/2Z7Gd1vC5nSuTH7B1A6HevkiMfA4svuCd+93geSmRfFIKEGIxnjSi6cyD/FO
+DVB7q/+lVA3uDmZ5j2dw15ccxGGYLfq3WjVOPtR3oL3a70LeGHzkeKYBTalENkphR7f4669j
+C8r+3AK6vIGw06h5cCvMFZGsGQZmulga1JS8LcVim1vcmMH4s3CuEIYE3XppU3Dgl4JURI0R
++5inyxpurkWEQ8ACFLBr2N/HK+AANqY8e231YwkiGdGVjhOxYGzWW5V+c5O93C4266wLvg8c
+2SCYMGryh38Zt/TkeNvlTEAYZemgqyaRbkjRY6+y6AAHitDL1LvJj1ADhxJkri9KMIICpgIB
+ADCBjTCBhzELMAkGA1UEBhMCUlUxEzARBgNVBAgTClNvbWUtU3RhdGUxFjAUBgNVBAcTDVN0
+LVBldGVyc2J1cmcxDTALBgNVBAoTBFRlc3QxDTALBgNVBAsTBHRlc3QxDzANBgNVBAMTBlRl
+c3RlcjEcMBoGCSqGSIb3DQEJARYNdGVzdEB0ZXN0LmNvbQIBAzANBgkqhkiG9w0BAQEFAASC
+AgAMJzwFWoFS70JsXSe83zwlkduPHfK+CNeHG0cTizN7TBS/NOgnTK85hGtc5JZSowEpZpkU
+e1O4dYGRl2YHXAAY/J//BrDhj8mLhukIjyfd4/Wy6KDIkP1fvbLPpDNSg98FUtcWSozC3IJy
+soTJPyWSN8Ui5GYX/st/zW2RGPk8fmrX95joodvOJt38AQGpnVFMIpFCqzS1y+JCRR0l1dmb
+5gVn75rFEVTGVNmSguXJaKDGqgwx39QHWhXxpzz166F1L2Ys4s5eKeYjK+9jtqCeTYAjop0f
+E3+W9SHksM+0B9p2l7jUM74/LQNyXcA+l1ab8h6iEIWTRIQ8L5CzJUJGzsSREgffylBAAGEq
+0bV8vQBXIi0YTRhKU1kBfAFBZxlsS2Vmrxn+RGQz11hRjHH69VTyPFV2h978YBnIqt8DoByv
+mLVg+P8r7LvcrCsrKUFAGaHENILbdiKilPUBhV4djmD0Y4pHsEneMinjLa3ayn0mLGWW9KcV
+NaxXdrMg1prLPNY8JRYXSg8zVpPYDW3hG0abvFXKztp+J+dGKXlb3D+VuOoP4FYc2JcGxxdU
+hSTRq8Ee4OtkRGuSTLgXARUYofH4nqAor6+1ixr84QnqK5h61qLPXSJnA6Dox2fUmeRsWm7x
+psCK7Y9v7fFK2WST4LE5fmpyHVtGyOmih4Ug8TCABgkqhkiG9w0BBwEwFAYIKoZIhvcNAwcE
+CGA0oBrKobsjoIAEggIwV0YAtLgEB/F5GEZ8ghp6+H1WJmwn5U9tNNNmzWAif5FytdXoSRL3
+SwJMi0B6IINu0uDV3X47glhdCazJTKiduwF55oEARPPpvFpSqEKPg5KTf47bX0Q41669H9jl
+znFFzgzIZQFl4gpMeg87QJOq+rG3TxWBTOiynBisTT816UrlqYC9LqMEr3laq/psuI0vZLyr
+rr68FrlvO8c21c77RA+oUQ/fFb97SrvmnPpX0DtKLD9Z/n+smPzRA2kUFs+PlbKy7FnH4zX/
+8UCMCYwvtGWXMQA+28aiI4RYw7nJbt+B6FHXQ+ZR9tJ2sVCvSMhGX4ao8UVBLZKA2IE9M2BK
+fX0+o41IhWf5qRT04yVvHlaygCxIKaUzTPu2PTTtez53DPX91s3joLUHi1/a9bpHODuP57dv
+76c1vSg3qJURtVbrAptDpR54DV4bvdRcig6TKoeLw8tjqf0F8glhMIeg6NF7BbUwYtKPL7bm
+0r3bN72/BENBcGyNl/Ou9dZLV3O4+zs1MEoE972LW61AH0voSZVV8Roj0mceSMgpTwU0RY7G
+fzARr/pGh1NwLGVBBYT/5UHIUTuMAVHcZvaFsZjX9kPKnVtTeQjhnYRCfdHVYVoIQnkzn6Sy
+1aGmsv/z6vsF4eSAs9HrF8kwFWRFUJ2YHSl0dqNyvlqvX0VDeK/Ks6ei8AVYvfMdkY5bCbPE
+6KpdkYGyNLJff13Ef1xOcqJgqNWdzGA7S9pnSw+J85UxMKQECNY4jO2xzB+FAAAAAAAAAAAA
+AA==
View
44 t/data/with-text-attachment.eml
@@ -0,0 +1,44 @@
+Date: Fri, 22 Dec 2006 05:24:50 +0300
+From: root@localhost
+X-Mozilla-Draft-Info: internal/draft; vcard=0; receipt=0; uuencode=0
+User-Agent: Thunderbird 1.5.0.9 (X11/20061221)
+MIME-Version: 1.0
+To: sender@test.com
+Subject: test
+Content-Type: application/x-pkcs7-mime; name="smime.p7m"
+Content-Transfer-Encoding: base64
+Content-Disposition: attachment; filename="smime.p7m"
+Content-Description: S/MIME Encrypted Message
+
+MIAGCSqGSIb3DQEHA6CAMIACAQAxggQ8MIIBjgIBADB2MGIxCzAJBgNVBAYTAlpBMSUwIwYD
+VQQKExxUaGF3dGUgQ29uc3VsdGluZyAoUHR5KSBMdGQuMSwwKgYDVQQDEyNUaGF3dGUgUGVy
+c29uYWwgRnJlZW1haWwgSXNzdWluZyBDQQIQBgzQJigV55Om1dc1u4CuYzANBgkqhkiG9w0B
+AQEFAASCAQByY+Ab0R/EB6cPAU13dB+uXWsJ7xCIuAwC0On3jEKeWssROQboi68xpezuB9Xn
+NyrJiY/m/BG7wTovEX5I4zzZxTLg+wBKnr3eGJ26WbiwTuqkH8JwilE+NKI8H5FQjw4gNS59
+meAXcrVSixoE+Ztii6jMs3EeiUqf4e0fXniiAe6nujMYBD9OWB9BsafksewverYE4mKZ/x6D
+a/6hQso52ZL/hEn/2Rq8O7oxF9Jx4qRs8AAnF42RK1YTzL6kLQU76tIHKJhJMrwDTAlazKM/
+zOrG4xradlg7gzagFCwPXP2oyUOY/lN62blqXuObN3mjlf6MMHUj9y1TTTuKxHttMIICpgIB
+ADCBjTCBhzELMAkGA1UEBhMCUlUxEzARBgNVBAgTClNvbWUtU3RhdGUxFjAUBgNVBAcTDVN0
+LVBldGVyc2J1cmcxDTALBgNVBAoTBFRlc3QxDTALBgNVBAsTBHRlc3QxDzANBgNVBAMTBlRl
+c3RlcjEcMBoGCSqGSIb3DQEJARYNdGVzdEB0ZXN0LmNvbQIBAzANBgkqhkiG9w0BAQEFAASC
+AgAdzb7zD1rdx95PAkUvjHRVkT/cex7JyGYSql9Ew86F6mxIThl+ZulVEgdiTba0zxoNl6Fj
+p2P4SpvpcNAFt2GzR6bChEgv2r+bkQ2CkOCB/qNuthjgTeJsKiEaLkSP/G8AJugmJco9MXN/
+o+6mEbdmGdeG8qu+12BP42f+je9UxtQCqdRB7iZuetQ33V2LMYDyH4UE+sSvBhn6a87wC7bE
+mJKN16G8CxQKjZcf9qc68RrvfR9y3X84l2CrlgxaafbUwBnNcTdbXzvkeT/sYPaF+LwMImpc
+mddzN+VpCRKVgH04zO2SjSqXap0FdCcMW9Namvi+pI2+ahSlrFB9NBqcOJQvCC1hv+pY2d6a
+sIF/I3lvf1/phKNyO8+BbvO/HungjeF/kbdg/Ab9ABrb/RadqS1CRYN5nya51nS/r28lmkav
+4z9CvJEcMiBDj+CHME2hT9k8rZ3Gcoz8dhd1aIJGGvp9Y65VDSmvNmRG5dfeUCw82zKcnkp+
+ZZf6XYLl9+MaT12fx7qP0ScF6UgNNSza7r2a2tWvyssxnyyBXL1jsczwGZRRUf6Ufv4wyyWf
+/mAhq3AAiQ8iMWqJbTMNRCHIVSvEPfrQwbWtoHovlehtUuhKLFWZQiAMhiQVCLLKVyNKAcrG
+oQfNCsrh+HGat7FsV1bXMC7p0j4ljfU9kl0JUjCABgkqhkiG9w0BBwEwFAYIKoZIhvcNAwcE
+CMA4cFD8aLwqoIAEggIIxSwx7MnbaVGmvr6I5u/GPUKqBzDT4g3Pnstsao+WLstsLYulLBbR
+M4tBqQyLT3vJv5OaVgLB4A0/wYbfNfNm5NCdf+1SkjHp0B+VZSqbNPzN6SW9mDET6ZMk/kL6
+o1Td8ePF9SkIZTlWI7ns9PRpPC28iKAV1/d1rd2EMrT4gjSnZX9MUNa6YrDc9UmFAq3E6+IM
+WFA2xVuemCamiHz8ecfQojjAexMKX9W7gBSwslDvT1COKchUlceJ0PSPCUBmsqpjCX7ezG1h
+4gs5nBWrxiIVwhcN2VU9WK5TMOR72Svibv7nSQbv5iwDBANSN8p4Y3HfWbq9EsCiiDP/cJcQ
+BMi0E+wyWvkVwjywX9e5xCrq4fWfuwYELttrO3yfthr9coDg3xo+EMBegmlHGp0mSlW3VRO3
+mRwlLyrO7RYyfo3rupVlocrtkcS8WNXWhyXDy7ws068fX+6wfPbp3b2Q9fU1mROii7zNgzZM
+teiun37qth35FrbeClPEhjs6KDP1LBGOjFdqvXaSBkYSA4Z7+mG0YSfKrwoQahEn0V+Y4K+S
+PQGXBO3/5ObXsNaCFeGD0mCU2cvRZsrgK0/hcgcPiwVjSPbmLQhwfYRBlqA7QrvSbF4VNxid
+8UUx3eVgrVUGH//ZaB7K+CrAGiIY6C1dmciodun7v7h8QZk9yivQeQse+xhSBZZUiAQI1dPS
+qA5aPVUAAAAAAAAAAAAA
View
6 t/pod-coverage.t
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+all_pod_coverage_ok();
View
6 t/pod.t
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+all_pod_files_ok();
View
230 t/smime-incoming.t
<
@@ -0,0 +1,230 @@
+#!/usr/bin/perl
+use strict;
+use Test::More;
+eval 'use RT::Test; 1'
+ or plan skip_all => 'requires 3.7 to run tests.';
+
+plan tests => 47;
+use File::Temp;
+use IPC::Run3 'run3';
+use String::ShellQuote 'shell_quote';
+use RT::Tickets;
+use FindBin;
+use Cwd 'abs_path';
+
+RT->Config->Set( LogToScreen => 'debug' );
+RT->Config->Set( LogToSyslog => 'debug' );
+RT->Config->Set( 'OpenSSLPath', '/usr/bin/openssl' );
+RT->Config->Set( 'SMIMEKeys', abs_path('testkeys') );
+RT->Config->Set( 'SMIMEPasswords', {'sender@example.com' => '123456'} );
+RT->Config->Set( 'MailPlugins' => 'Auth::MailFrom', 'Auth::SMIME' );
+
+RT::Handle->InsertData('etc/initialdata');
+
+my ($url, $m) = RT::Test->started_ok;
+# configure key for General queue
+$m->get( $url."?user=root;pass=password" );
+$m->content_like(qr/Logout/, 'we did log in');
+$m->get( $url.'/Admin/Queues/');
+$m->follow_link_ok( {text => 'General'} );
+$m->submit_form( form_number => 3,
+ fields => { CorrespondAddress => 'sender@example.com' } );
+
+my $mail = RT::Test->open_mailgate_ok($url);
+print $mail <<EOF;
+From: root\@localhost
+To: rt\@$RT::rtname
+Subject: This is a test of new ticket creation as root
+
+Blah!
+Foob!
+EOF
+RT::Test->close_mailgate_ok($mail);
+
+{
+ my $tick = get_latest_ticket_ok();
+ is( $tick->Subject,
+ 'This is a test of new ticket creation as root',
+ "Created the ticket"
+ );
+ my $txn = $tick->Transactions->First;
+ like(
+ $txn->Attachments->First->Headers,
+ qr/^X-RT-Incoming-Encryption: Not encrypted/m,
+ 'recorded incoming mail that is not encrypted'
+ );
+ like( $txn->Attachments->First->Content, qr'Blah');
+}
+
+# test for encrypted mail
+my $buf = '';
+
+run3(
+ shell_quote(
+ qw(openssl smime -encrypt -des3),
+ -from => 'root@localhost',
+ -to => 'rt@' . $RT::rtname,
+ -subject => "Encrypted message for queue",
+ 'testkeys/sender@example.com.crt'
+ ),
+ \"Subject: test\n\norzzzzzz",
+ \$buf,
+ \*STDERR
+);
+
+my $mail = RT::Test->open_mailgate_ok($url);
+print $mail $buf;
+RT::Test->close_mailgate_ok($mail);
+
+{
+ my $tick = get_latest_ticket_ok();
+ is( $tick->Subject, 'Encrypted message for queue',
+ "Created the ticket"
+ );
+
+ my $txn = $tick->Transactions->First;
+ my $attach = $txn->Attachments->First;
+ is( $attach->GetHeader('X-RT-Incoming-Encryption'),
+ 'Success',
+ 'recorded incoming mail that is encrypted'
+ );
+ like( $attach->Content, qr'orz');
+}
+
+{
+ open my $fh, $FindBin::Bin.'/../t/data/simple-txt-enc.eml';
+ ok(open($mail, "|$RT::BinPath/rt-mailgate --url $url --queue general --action correspond"), "Opened the mailgate - $!");
+ print $mail do { local $/; <$fh>};
+ close $mail;
+
+ my $tickets = RT::Tickets->new($RT::SystemUser);
+ $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' );
+ $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' );
+ my $tick = $tickets->First;
+ ok( UNIVERSAL::isa( $tick, 'RT::Ticket' ) );
+ ok( $tick->Id, "found ticket " . $tick->Id );
+ is( $tick->Subject, 'test', 'Created the ticket' );
+
+ my $txn = $tick->Transactions->First;
+ my $attach = $txn->Attachments->First;
+ is( $attach->GetHeader('X-RT-Incoming-Encryption'),
+ 'Success',
+ 'recorded incoming mail that is encrypted'