gpg-ezmlm/GpgEzmlm.pm

package GpgEzmlm;

use strict;
use Fcntl;
use File::Sync qw(fsync sync);
use Time::Local;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use IPC::Open3;
use IO::Select;
require Exporter;

@ISA = qw(Exporter);

@EXPORT = qw(
		 mydie
		 copy
	         mail
		 runcmd
		 readConfig
		 hashaddr
		 issub
		 rfc822date
		 subscribe
		 prepare
		 reject
		);

$VERSION = '0.3.3';

=head1 NAME

GpgEzmlm - Internal functions for the gpg-ezmlm mailing list suite

=head1 SYNOPSIS

  use GpgEzmlm;

  Actually, don't. This is an internal API only, not really intended
  for use by non-gpg-ezmlm programs.

=head1 DESCRIPTION

Perl module containing common code for the gpg-ezmlm
mailing list suite of scripts

=head2 EXPORT

mydie - Acts like die, but the first argument sets the exit code.
mail - Used to inject mail to qmail-queue
runcmd - Runs a command, and stuffs input to it, puts output and err in
         scalars. Uses select() to make sure everything moves smoothly
readConfig - Reads options from config file
hashaddr - Hashes an email addr into one character. Used to determine which
           subscriber file a subscriber is/would be in.
issub - Determines if a given email addr is currently subscribed or not.
rfc822date - Returns the date in RFC 822 format
subscribe - Subscribes an email addr to the list
prepare - Decrypts and encrypts messages to the list.
reject - Sends a rejection email to the sender, explaining the reason 
         for rejection.


=head1 AUTHOR 

Todd MacDermid <tmacd@synacklabs.net>

=head1 SEE ALSO

L<perl>.

=cut

#mydie - Just a simple wrapper that I use instead of die(), because
#qmail pays attention to exit values of the script, and this gives
#me control over that

sub mydie {
  my $error = shift;
  my $string = shift;
  print $string;
  exit $error;
}

#readConfig - opens the config file, sets a few default values, and 
#sets flags and values in a hash that controls behavior of the program.
#definitions of values below:
#
#keyDir - Where are the keyrings stored?
#tempDir - Where the temporary purgatory keyring is stored
#signMessages - Should the ML sign messages
#requireSigs - Do we require content to be signed - NOT YET IMPLEMENTED
#allowKeySubmission - Do we allow users to submit keys through the mgmt 
#                     interface
#stripMime - Should we strip out pgp-encrypted MIME headers? - NOT YET IMPLEMENTED
#encapsulateMime - Should we add in pgp-encrypted MIME headers? - NOT YET IMPLEMENTED
#allowAttach - Whether to allow only inline, or allow attachments as well. - NOT YET IMPLEMENTED
#nokeyNocrypt - Forward messaged unencrypted if no key?
#verifiedKeyReq - Require keys to be verified?
#encryptToAll - Encrypt once, to all keys on list
#requireSub - Only allow subscribers to a list to post to it.
#subList - Are we a sublist? Not set here for ezmlm compat reasons.
#archived - Whether we'll archive messages. Set outside of the main config file
#           for ezmlm compatibility
#outhost - The domain hosting the mailing list. Set outside of the main
#          config file for ezmlm compatibility
#outlocal - The name of the mailing list, e.g. crypt-ml. Set outside of the 
#           main config file for ezmlm compatibility
#sublist - If it exists, this is the main list that we are a sublist for.
#          Set outside of the main config file for ezmlm compatibility
#allowUnencrypted - Whether to forward unencrypted content. - NOT YET IMPLEMENTED

sub readConfig {
  my $configFile = shift;
  my $configRef = shift;

#DEFAULT VALUES
  $$configRef{keyDir} = ".gnupg";
  $$configRef{tempDir} = "tmp";
  $$configRef{gpg} = "/usr/local/bin/gpg";
  $$configRef{qmailDir} = "/var/qmail/bin";
  $$configRef{allowUnencrypted} = 1;
  $$configRef{signMessages} = 1;
  $$configRef{allowKeySubmission} = 1;
#END DEFAULTS

  open OUTHOST, "<outhost" or mydie(111, "unable to open outhost: $!\n");
  $$configRef{outhost} = <OUTHOST>;
  chomp $$configRef{outhost};
  close(OUTHOST);

  open OUTLOCAL, "<outlocal" or mydie(111, "unable to open outlocal: $!\n");
  $$configRef{outlocal} = <OUTLOCAL>;
  chomp $$configRef{outlocal};
  close(OUTLOCAL);

  if(open ARCHIVED, "<archived") {
    if (defined($$configRef{archived} = <ARCHIVED>)) {
      chomp $$configRef{archived};
    }
    close(ARCHIVED);
  }

  if(open SUBLIST, "<sublist") {
    if (defined($$configRef{sublist} = <SUBLIST>)) {
      chomp $$configRef{sublist};
    }
    close(SUBLIST);
  }

  if (open CONFIG, "$configFile") {
    while (defined(my $confline = <CONFIG>)) {
      chomp $confline;
      if ($confline =~/^\s*keyDir\s+(\S+)/i) {
	$$configRef{keyDir} = $1;
      } elsif ($confline =~/^\s*tempDir\s+(\S+)/i) {
	$$configRef{tempDir} = $1;
      } elsif ($confline =~/^\s*gnupg\s+(\S+)/i) {
	$$configRef{gpg} = $1;
      } elsif ($confline =~/^\s*qmailbin\s+(\S+)/i) {
	$$configRef{qmailDir} = $1;
      } elsif ($confline =~/^\s*signmessages\s+(\S+)/i) {
	if ($1 =~ /n/i) { 
	  $$configRef{signMessages} = 0;
	}
      } elsif ($confline =~/^\s*RequireSigs\s+(\S+)/i) {
	if ($1 =~ /y/i) { 
	  $$configRef{requireSigs} = 1;
	}
      } elsif ($confline =~/^\s*StripMime\s+(\S+)/i) {
	if ($1 =~ /y/i) { 
	  $$configRef{stripMime} = 1;
	}
      } elsif ($confline =~/^\s*EncapsulateMime\s+(\S+)/i) {
	if ($1 =~ /y/i) { 
	  $$configRef{encapsulateMime} = 1;
	}
      } elsif ($confline =~ /^\s*AllowAttach\s+(\S+)/i) {
	if ($1 =~ /y/i) { 
	  $$configRef{allowAttach} = 1;
	}
      } elsif ($confline =~/^\s*NokeyNocrypt\s+(\S+)/i) {
	if ($1 =~ /y/i) { 
	  $$configRef{nokeyNocrypt} = 1;
	}
     
      } elsif ($confline =~/^\s*allowKeySubmission\s+(\S+)/i) {
	if ($1 =~ /n/i) { 
	  $$configRef{allowKeySubmission} = 0;
	}
      } elsif ($confline =~/^\s*VerifiedKeyReq\s+(\S+)/i) {
	if ($1 =~ /y/i) { 
	  $$configRef{verifiedKeyReq} = 1;
	}
      } elsif ($confline =~/^\s*allowUnencrypted\s+(\S+)/i) {
	if ($1 =~ /n/i) {
	  $$configRef{allowUnencrypted} = 0;
	}
      } elsif ($confline =~/^\s*EncryptToAll\s+(\S+)/i) {
	if ($1 =~ /y/i) { 
	  $$configRef{encryptToAll} = 1;
	}
      } elsif ($confline =~/^\s*RequireSub\s+(\S+)/i) {
	if ($1 =~ /y/i) { 
	  $$configRef{requireSub} = 1;
	} 
      } elsif ($confline =~/^\s*strictlevel\s+(\d+)/i) {
	$$configRef{strictlevel} = $1;
      }
    }
    close(CONFIG);
  }
}

#copy takes a filename and a buffer, and appends the contents of that
#file to the buffer. These files are the messages that the mailing list
#sends back. If a line consists of a !R or !A, or contains the
#tags <#l#>, <#n#>, or <#h#>, then the contents of that line are replaced.


sub copy {
  my $file = shift;
  my $buffer = shift;
  my $isHeader = shift;
  my $configRef = shift;
  my $confirm = shift;
  my $target = shift;
  my $outmsgnum = shift;

  open FILE, "<$file" or mydie(111, "unable to open $file: $!\n");
  
  while (my $line = <FILE>) {
      $line =~ s/^\!R/$confirm/;
      $line =~ s/^\!A/$target/;
      $line =~ s/<\#l\#>/$$configRef{outlocal}/;
      $line =~ s/<\#h\#>/$$configRef{outhost}/;
      $line =~ s/<\#n\#>/$outmsgnum/;
      if($isHeader > 0) {
	  if($line =~ /\S+/) {
	      $$buffer .= $line;
	  }
      } else {
	  $$buffer .= $line;
      }
  }
  close(FILE);
}


#runcmd - Runs a command, pushes all the input through it, and writes
#to output and err. Select()s across reading and writing, for those 
#processes that can't hold all your input before they need to be read from
#Solves a problem with large messages being pushed through gpg. Thanks to
#tcannon@noops.org for the catch.

sub runcmd {
  my $cmdline = shift;
  my $inputref = shift;
  my $outputref = shift;
  my $errref = shift;

  $$outputref = "";
  $$errref = "";
  my $readpos = 0;
  my $writepos = 0;
  my $errpos = 0;
  my $writeDone = 0;
  my $readDone = 0;
  my $errDone = 0;
  my $done = 0;
  my $len;
  my @ready = ();
  my $stringLength;

  my $pid = open3(\*WRITE, \*READ, \*ERR, "$cmdline") or
    mydie(100, "Cannot run $cmdline\n");
  my $select = IO::Select->new();
  if($$inputref) {
    $select->add(\*WRITE);
    $stringLength = length($$inputref);
  } else {
    $writeDone = 1;
    close(WRITE);
  }
  $select->add(\*READ);
  $select->add(\*ERR);

  while(!$done) {
    if ((!$writeDone) and (@ready = $select->can_write(0))) {
      foreach my $handle (@ready) {
	if($handle == \*WRITE) {
	  if($stringLength - $writepos > 4096) {
	    $len = syswrite(WRITE, $$inputref, 4096, $writepos);
	  } else {
	    $len = syswrite(WRITE, $$inputref, ($stringLength - $writepos), $writepos);
	  }
	  if ($len > 0) {
	    $writepos += $len;
	  } else {
	    mydie(111,"System write error: $!\n");
	  }
	  if($writepos == $stringLength) {
	    $writeDone = 1;
	    $select->remove(\*WRITE);
	    close (WRITE);
	  }
	}
      }
    }
    if (@ready = $select->can_read(0)) {
      foreach my $handle (@ready) {
	if($handle == \*READ) {
	  $len = sysread(READ, $$outputref, 4096, $readpos);
	  if(defined($len)) {
	    if($len > 0) {
	      $readpos += $len;
	    } else {
	      $readDone = 1;
	      close(READ);
	      $select->remove(\*READ);
	    }
	  } else {
	    die "System read error: $!\n";
	  }
	}
	if($handle == \*ERR) {
	  $len = sysread(ERR, $$errref, 4096, $errpos);
	  if(defined($len)) {
	    if($len > 0) {
	      $errpos += $len;
	    } else {
	      $errDone = 1;
	      close(ERR);
	      $select->remove(\*ERR);
	    }
	  } else {
	    die "System read error: $!\n";
	  }
	}
      }
    }
    
    # I know the below looks like an error, that it should be 
    # ($errDone and $readDone and $writeDone), but I've been testing this,
    # and the select never lets me through to pick the EOF off the READ
    # filehandle on gpg encrypts. If you know why, please enlighten me.

    if(($errDone or $readDone) and $writeDone) {
      $done = 1;
    }
  }

  # OK, I actually am having issues with read not getting everything... <sigh>
  # Hopefully, the below read will empty everything out of the read buffer.

  while($readDone != 1) {
      $len = sysread(READ, $$outputref, 4096, $readpos);
      if(defined($len)) {
	  if($len > 0) {
	      $readpos += $len;
	  } else {
	      $readDone = 1;
	      close(READ);
	      $select->remove(\*READ);
	  }
      }
  }
  return($pid);
}

#mail - injects the mail into the system. Headers and body contained in
#$message

sub mail {
  my $qmailqueue = shift;
  my $message = shift;
  my $from = shift;
  my @to = @_;
  
  pipe READ0, WRITE0;
  pipe READ1, WRITE1;
  my $pid = fork();
  if ($pid) {
    close(READ0);
    close(READ1);
  } else {
    close(WRITE0);
    close(WRITE1);
    
    fcntl READ0, &F_GETFL, 0 or mydie(111,"READ0 not open?\n");
    close(STDIN);
    fcntl READ0, &F_DUPFD, 0;   
    fcntl READ1, &F_GETFL, 0 or mydie(111,"READ1 not open?\n");
    close(STDOUT);
    fcntl READ1, &F_DUPFD, 1;
    
    exec "$qmailqueue";
  }
  print WRITE0 "$message\n";
  close (WRITE0);
  print WRITE1 "F";
  print WRITE1 "$from";
  print WRITE1 "\0";
  foreach my $to (@to) {
    print WRITE1 "T";
    print WRITE1 "$to";
    print WRITE1 "\0";
  }
  print WRITE1 "\0";
  close(WRITE1);
}

#ezmlm separates subscriber lists into single character files. The below
#replicates the ezmlm algorithm to determine the username to filename
#mapping, so gpg-ezmlm can convert an existing ezmlm list and not need
#to convert the subscriber list files.

sub hashaddr {
  my $addr = shift;
  my $h = 5381;
  my $packed;
  {                 # Nasty nasty icky perl hack forthcoming
    use integer;
    my @addr = split "", $addr;
    for (my $j = 0; $j < length $addr; $j++) {
      $h = ($h + ($h << 5) ^ ord($addr[$j]));
      $h = $h & 0xffffffff   # To deal with 64 bit architectures 
    }
    $packed = pack "l", $h;
  }
  my $unpacked = unpack "L", $packed;
  my $ch = chr(64 + ($unpacked % 53));
  return ($ch);
}

#issub checks to see if a given address is subscribed to the mailing
#list. Returns 0 if not subscribed, 1 if subscribed  

sub issub {
  my $address = shift;
  my $addr = "T" . lc($address);
  my $char = hashaddr($addr);
  open FD, "<subscribers/$char" or return(0);
  my $line = <FD>;
  foreach my $ss (split "\0",  $line) {
    if ($ss =~ qq/^$addr/) {
      return(1);
    }
  }
  return(0);
}

#rfc822date returns a string containing the date in rfc822 format.
#You were expecting it to break RSA keys? ^_^

sub rfc822date {
  use integer;
  my $epoch = time();
  my $localtime = localtime;
  my $retstring;
  if ($localtime =~ /^(\S+)\s+(\S+)\s+(\d+)\s+(\d+\:\d+\:\d+)\s+(\d+)/) {
    $retstring = "$1, $3 $2 $5 $4 ";
  }
  my $tl = timelocal((localtime)[0,1,2,3,4,5]);
  my $tg = timegm((localtime)[0,1,2,3,4,5]);
  my $secdiff = $tg - $tl;
  my $hourdiff = $secdiff / 3600;
  my $mindiff = ($secdiff/60) % 60;
  my $offset;
  $offset = sprintf ("%.02d%.02d", $hourdiff, $mindiff);
  $retstring .= $offset;
  return $retstring;
}

#subscribe actually adds the subscriber email address to one of the 
#subscriber list files, if it's not there already, shorter than
#400 characters, and a whole bunch of other potential error conditions.
#The subscriber files are a set of 53 single character files contained
#in the subscribers subdir. Which file a subscriber belongs in is determined
#by hashaddr

sub subscribe {
  my $userhost = shift;
  my $flagadd = shift;
  my $LOCK_EX = 2;
  
  open LOCK, ">lock" or mydie(111,"unable to open lock: $!\n");
  flock LOCK, $LOCK_EX or mydie(111,"unable to obtain lock: $!\n");
  
  if($userhost =~ /\n/) {
    print "address contains newline\n";
    return -8;
  }
  
  my $addr = "T" . lc($userhost);
  if (length($addr) > 400) {
    print "address is too long\n";
    return -7;
  }
  if (!($addr =~ /\@/)) {
    print "address does not contain @\n";
    return -6;
  }
  
  my $ch = hashaddr($addr);
  my $fn = "subscribers/$ch";
  my $fnnew = $fn."n";
  if (!(open FDNEW, ">$fnnew")) {
    print "unable to write $fnnew: $!\n";
    return -4;
  }
  
  my $flagwasthere = 0;
  if (!(open FD, "$fn")) {
   # print "unable to read $fn: $!\n";  # Need to separate ENOENT from other
   # return -3;                         # errors. fix later.
  } else {
    my $line = <FD>;
    foreach my $ss (split "\0",  $line) {
      if ($ss =~ qq/^$addr/) {
	$flagwasthere = 1;
	if (!($flagadd)) { next; }
      }
      print FDNEW "$ss\0";
    }
    close FD;
  }
  if ($flagadd && !$flagwasthere) {
    print FDNEW "$addr\0";
  }
  my $fdnew = select(FDNEW);
  $| = 1; # flush FDNEW's buffers
  select($fdnew);
  if (!(fsync(FDNEW))) {
    close (FDNEW); 
    print "unable to write $fnnew: $!\n";
    return -4; 
  }
  close FDNEW;
  if (!(rename "$fnnew", "$fn"))  {
    print "unable to move temporary file to $fn: $!"; 
    return -5;
  }
  return ($flagadd ^ $flagwasthere);
}

# prepare takes in a raw message in the form of an array of lines, a config 
# hash reference, and an array of recipients. It will return the message 
# encrypted for all recipients that it has keys for, or if it has no keys, 
# it will return error messages.

sub prepare {
  my $messageArrayRef = shift;
  my $configref = shift;
  my $archived = shift;
  my @recipients = shift;

  my $inheader = 1;
  my $flagmlwasthere = 0;
  my $flagbadfield = 0;
  my $flagincrypted = 0;
  my $incontenttype = 0;
  my %headerremovemap = ();
  my @header = ();
  my @cryptedmessage = ();
  my @message = ();
  my @decryptedmessage = ();
  my $numcrypted = 0;
  my $nummessage = 0;
  my $gpg = "$$configref{gpg} --homedir $$configref{keyDir}";

  my $mydtline = "Delivered-To: mailing list ".$$configref{outlocal}."\@".$$configref{outhost};

  open HEADERRM, "<headerremove" or 
    mydie(111, "unable to open headerremove: $!\n");
  while (<HEADERRM>) {
    chomp;
    /^(\S+)/;
    $headerremovemap{(lc $1)} = 1;
  }
  close(HEADERRM);

  foreach my $line (@$messageArrayRef) {
    if(!($line =~ /\S+/)) {
      $inheader = 0;
    }
    if($inheader) {
      if($line =~ /^(\S+):/) {
	$flagbadfield = 0;
	$incontenttype = 0;
	if($headerremovemap{(lc $1)}) {
	  $flagbadfield = 1;
	} else {
	  $flagbadfield = 0;
	}
      } 
	
      if($archived) {
	if ($line =~ /^subject:/i) {
	  $line =~ s/subject:/Subject: \[$$configref{outlocal} archive \#$archived\]/i;
	}
      } else {
	if ($line =~ /^$mydtline/i) {
	  mydie(100, "this message is looping: it already has my Delivered-To line (#5.4.6): $line\n");
	}
      }

      if ($line =~ /^mailing-list:/i) {
	$flagmlwasthere = 1;
      }

      if(!($flagbadfield)) {
	push @header, $line;
      }
    } else {
      if (!($archived)) {
	if($$configref{subList}) {
	  if (!($flagmlwasthere)) {
	    mydie(100, "sublist messages must have Mailing-List (#5.7.2)\n");
	  }
	} else {
	  if ($flagmlwasthere) {
	    mydie(100, "message already has Mailing-List (#5.7.2)\n");
	  }
	}
      }

      if ($line =~ /-----BEGIN PGP MESSAGE-----/) {
	$flagincrypted = 1;
      }
      
      if($flagincrypted) {
	push @{$cryptedmessage[$numcrypted]}, $line;
      } else {
	push @{$message[$nummessage]}, $line;
      }
      
      if ($line =~ /-----END PGP MESSAGE-----/) {
	$flagincrypted = 0;
	$numcrypted++;
	$nummessage++;
      } 
    }
  }
    
  for(my $i = 0; $i < $numcrypted; $i++) {
    my $error;
    my @signlines = ();
    my $goodsig = 0;
    my $trustedsig = 1;
    my $ciphertext = join '', @{$cryptedmessage[$i]};
    runcmd("$gpg -d", \$ciphertext, \$decryptedmessage[$i], \$error);
    foreach my $errline (split /\n/, $error) {
      if (($errline =~ /decryption failed/) or
	  ($errline =~ /invalid packet/)) {
	$decryptedmessage[$i] =  "Unable to decrypt content";
      }
      #      if (/signature/) {
      #	       push @signlines, $_;
    }
  }
  my $mail;

  $mail .= $mydtline. "\n";

  if (-r "headeradd") {
      copy("headeradd", \$mail, 1, $configref);
  }

  foreach my $hline (@header) {
    $mail .= $hline;
  }
  for (my $i = 0; $i < ($numcrypted+1); $i++) {
    if ($message[$i]) {
      foreach my $line (@{$message[$i]}) {
	$mail .= $line;
      }
    }
    if ($decryptedmessage[$i]) {
      my $recipientline;
      foreach my $recipient (@recipients) {
	$recipientline .= " -r $recipient";
      }
      my $error;
      my $plaintext = $decryptedmessage[$i];
      my $ciphertext;
      if ($$configref{verifiedKeyReq}) {
	if ($$configref{signMessages}) {
	  runcmd("$gpg --no --no-tty --batch -sea $recipientline",
		 \$plaintext,
		 \$ciphertext,
		 \$error);
	} else {
	  runcmd("$gpg --no --no-tty --batch -ea $recipientline",
		 \$plaintext,
		 \$ciphertext,
		 \$error);
	}
      } else {
	if ($$configref{signMessages}) {
	  runcmd("$gpg --yes --no-tty --batch --always-trust -sea $recipientline",
		 \$plaintext,
		 \$ciphertext,
		 \$error);
	} else {
	  runcmd("$gpg --yes --no-tty --batch --always-trust -ea $recipientline",
		 \$plaintext,
		 \$ciphertext,
		 \$error);
	}
      }
      my $goodcrypt = 1;
      foreach my $errline (split /\n/, $error) {
	if (($errline =~ /public key not found/) or
	    ($errline =~ /no valid addressees/)) {
	  $goodcrypt = 0;
	  if(!($$configref{encryptToAll})) {
	    if ($$configref{nokeyNocrypt}) {
	      $mail .= $plaintext;
	    } else {
	      $mail .= "Encrypted content not forwarded due to lack of key.\n";
	    }
	  }
	}
      }
      if (($goodcrypt) or ($$configref{encryptToAll})) {
	$mail .= $ciphertext;
      }
    }
  }
  return($mail);
}