[Mimedefang] PGP automation?

[Gary Funck]

Follow-up.  I cobbled together a Perl script that attempts to
decrypt an encrypted email.  The script is attached.  I'd appreciate
any suggestions you have for improving it and making corrections.
The present method of finding passphrases will probably not pass
a security audit, but it gets me by for now.  This script is run from
procmail, behind a firewall, fyi.

Here's the procmail recipe:

#
# Check for  encrypted mail, and automatically decrypt.
# The 'w' flag says to wait for the filter to finish
# and to check the error code.  If the filter is unsuccesful
# (exit code != 0), the message will remain unchanged.
#
:0
* ^(Content-Type:.*(multipart/encrypted|application/pgp)|\
    X-pgp|\
    Subject:.*\[PGP\])
{

:0 c:
encrypted-mail

:0 fw
| $GPG_DECRYPT

}

I've only run this script against 20/so messages.  I expect
some surprises down the road.  I have a couple of questions:

1. When checking for multipart messages, I check for
particular types. Should I just check to see if the
message has body parts, as in:

replace:

  elsif ($entity->effective_type =~ m'^multipart/'
         || $entity->effective_type eq 'message/rfc822')

with:

  elsif ($entity->parts)

2. I was unsure what the RFC's say about the
handling of Old-Content-Type.  What I found is that I
needed to restore this field back to the current value
of Content-Type after decryption.  Sound okay?

3. The stripping CR/LF's proved necessary because they
were encapsulated in PGP armor before the mail was
transmitted via SMTP.  Since it was a text body part,
normally they would have been removed in transit, but
they weren't.  The script corrected this situation.
Makes sense?

I'm impressed by the power and flexibility of the
MIME and Mail tools.  Tip o' the hat to David Skol
and his Perl compatriots.

-- 
Gary Funck
-------------- next part --------------
#!/usr/bin/perl -w
#
# derived from mgpg-test, part of the Mail::GPG package
#
use strict;
use lib 'lib';
use Mail::GPG;
use Mail::Address;
use MIME::Parser;
use MIME::Entity;
use MIME::Head;
use MIME::Body;
use Getopt::Std;
use Socket;
use Net::Domain qw(hostname hostfqdn hostdomain);


sub decrypt_part ($)
{
  my $entity_ref = shift;
  my $entity = $$entity_ref;
  my $mg = Mail::GPG->new ();
  # mail is encrypted, ask Mail::GPG for the
  # key to decrypt this mail
  my ($key_id, $key_mail) = $mg->get_decrypt_key (entity => $entity);
  return 0 if !defined $key_id;
  my ($addr) = Mail::Address->parse($key_mail);
  return 0 if !defined $addr;
  my $uid = $addr->user;
  return 0 if !defined $uid;
  # obtain passphrase from file.
  my $home = $ENV{'HOME'} || '~';
  my $passfile = "$home/.gnupg/passphrase-${uid}.txt";
  my $passphrase;
  open (PASSPHRASE, "<$passfile") || return 0;
  chomp ( $passphrase = <PASSPHRASE> );
  close (PASSPHRASE);
  # decode the mail
  my ($decrypted, $result) = eval { $mg->decrypt (entity     => $entity,
		                                  passphrase => $passphrase) };
  return 0 if $@;
  $$entity_ref = $decrypted;
  return 1;
}

sub decrypt_msg ($);
sub decrypt_msg ($)
{
  my $entity_ref = shift;
  my $entity = $$entity_ref;
  my $decrypted = 0;
  my $mg = Mail::GPG->new ();
  if ( $mg->is_encrypted ( entity => $entity ) )
    {
      $decrypted = decrypt_part ($entity_ref);
      $entity = $$entity_ref;
      my $body = $entity->bodyhandle;
      if ($body) {
        my $btext = $body->as_string;
        if ($btext =~ /^[[:print:][:space:]]*$/)
          {
            # remove spurious <cr><lf>'s
            if ($btext =~ s/\r\n/\n/g)
	      {
	        my $B = $body->open("w") || return 0;
		$B->print($btext);
		$B->close;
	      }
	    $entity->effective_type('plain/text');
          }
      }
    }
  elsif ($entity->effective_type =~ m'^multipart/'
         || $entity->effective_type eq 'message/rfc822')
    {
      my @new_parts;
      for my $p ($entity->parts)
	{
	  $decrypted |= decrypt_msg (\$p);
          push @new_parts, $p;
        }
      $entity->parts (\@new_parts) if $decrypted;
    }
  return $decrypted;
}

$| = 1;

#  for debugging;
open (STDIN, "<test-pgp-mail.txt") || die "open failed" if $^P;

my $msg;

{
  local $/;
  $msg = <STDIN>; # slurp
}


my $entity = Mail::GPG->parse ( mail_sref => \$msg );

exit 2 if !decrypt_msg (\$entity);

# remove temp. files created by MIME::Entity
$entity->purge;

# Dump the decoded message
my ($from_line) = ($msg =~ /^(From [^\n]*)/);
print "$from_line\n" if defined $from_line;

my $host = hostfqdn();
my $ip_addr = inet_ntoa( scalar gethostbyname( $host || 'localhost' ));

my $head = $entity->head;
my $old_content_type = $head->get('Old-Content-Type');
if ($old_content_type)
  {
    $head->replace('Content-Type', $old_content_type);
    $head->delete('Old-Content-Type');
  }
$head->replace('X-GPG-Decrypt:', "Decrypted on host $ip_addr at " . scalar localtime);

$entity->print(\*STDOUT);