#!/usr/bin/perl
#
# Copyright (C) 2007 Manuel Mausz (manuel@mausz.at)
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later
# version.
#
# 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.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software Foundation,
# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
use strict;
use warnings;
our $VERSION = '0.1';
 
use Mail::DKIM 0.29;
use Mail::DKIM::Signer;
 
# enable support for "pretty" signatures, if available
eval 'require Mail::DKIM::TextWrap';
 
=head
config file structure
 - missing settings will be merged from global
 - domain-entry will also match its subdomains
 - specify "none" in types-tag to omit signing
 
<dkimsign>
  <global algorithm="rsa-sha256" domain="/var/qmail/control/me" keyfile="/var/qmail/control/dkim/global.key" method="simple" selector="beta">
    <types>dkim</types>
  </global>
  <example.com selector="beta2">
    <types>dkim</types>
    <types>domainkey</types>
  </example.com>
</dkimsign>
=cut
 
my $configfile = undef;
$configfile    = '/var/qmail/control/dkim/signconf.xml';
my $debugfile  = undef;
#$debugfile    = '/tmp/dkim.debug';
my $qremote    = '/var/qmail/bin/qmail-remote.orig';
my $binary     = 0;
our $config;
$config->{'global'} = {
  types     => 'dkim',
  keyfile   => '/var/qmail/control/dkim/global.key',
  algorithm => 'rsa-sha256',
  method    => 'simple',
  selector  => 'beta',
  # either string or file (first line of file will be used)
  domain    => '/var/qmail/control/me'
};
 
#-------------------------------------------------------------------------------
 
# read config file. safely
if (defined($configfile) && -r $configfile)
{
  eval 'use XML::Simple';
  if (!$@)
  {
    my $xmlconf;
    eval { $xmlconf = XMLin($configfile, ForceArray => 0); };
    qexit_deferral('Unable to read config file: ', $@)
      if ($@);
    ConfigMerge::merge($config, $xmlconf);
  }
}
 
# open debug file
my $debugfh = undef;
if (defined($debugfile))
{
  open($debugfh, '>', $debugfile)
    or qexit_deferral('Unable to open ', $debugfile, ' to writing: ', $!);
}
 
# generate signatures
my $dkim;
my $mailbuf = '';
eval
{
  my $conf = $config->{'global'};
  $dkim =  Mail::DKIM::Signer->new(
    Policy => 'MySignerPolicy',
    Debug_Canonicalization => $debugfh
  );
 
  if ($binary)
  {
    binmode STDIN;
  }
 
  while (<STDIN>)
  {
    $mailbuf .= $_;
    unless ($binary)
    {
      chomp $_;
      s/\015?$/\015\012/s;
    }
    $dkim->PRINT($_);
  }
  $dkim->CLOSE();
};
qexit_deferral('Error while signing: ', $@)
  if ($@);
 
# close debug file
close($debugfh)
  if (defined($debugfh));
 
# execute qmail-remote
unshift(@ARGV, $qremote);
open(QR, '|-') || exec { $ARGV[0] } @ARGV
  or qexit_deferral('Unable to run qmail-remote: ', $!);
foreach my $dkim_signature ($dkim->signatures)
{
  my $sig = $dkim_signature->as_string;
  $sig =~ s/\015\012\t/\012\t/g;
  print QR $sig."\012";
}
print QR $mailbuf;
close(QR);
 
#-------------------------------------------------------------------------------
 
sub qexit
{
  print @_, "\0";
  exit(0);
}
 
sub qexit_deferral
{
  return qexit('Z', @_);
}
 
sub qexit_failure
{
  return qexit('D', @_);
}
 
sub qexit_success
{
  return qexit('K', @_);
}
 
#-------------------------------------------------------------------------------
 
package ConfigMerge;
our $VERSION = '0.1';
 
# merge config hashes. arrays and scalars will be copied.
sub merge
{
  my ($left, $right) = @_;
  foreach my $rkey (keys(%$right))
  {
    my $rtype = ref($right->{$rkey}) eq 'HASH' ? 'HASH'
              : ref($right->{$rkey}) eq 'ARRAY' ? 'ARRAY'
              : 'SCALAR';
    if (!defined($left->{$rkey}) || $rtype ne 'HASH')
    {
      $left->{$rkey} = $right->{$rkey};
    }
    else
    {
      merge($left->{$rkey}, $right->{$rkey});
    }
  }
  return;
}
 
#-------------------------------------------------------------------------------
 
package MySignerPolicy;
use Mail::DKIM::SignerPolicy;
use base 'Mail::DKIM::SignerPolicy';
use Mail::DKIM::Signature;
use Mail::DKIM::DkSignature;
use Carp;
our $VERSION = '0.1';
 
sub apply
{
  my ($self, $signer) = @_;
  my $domain = undef;
  $domain = lc($signer->message_sender->host)
    if (defined($signer->message_sender));
 
  # merge configs
  while($domain)
  {
    if (defined($config->{$domain}))
    {
      ConfigMerge::merge($config->{'global'}, $config->{$domain});
      last;
    }
    (undef, $domain) = split(/\./, $domain, 2);
  }
 
  my $conf = $config->{'global'};
  return 0
    if (!defined($conf->{'types'}) || ($conf->{'types'}) eq 'none');
 
  # set key file
  $signer->key_file($conf->{'keyfile'});
 
  # parse (signature) domain
  if (substr($conf->{'domain'}, 0, 1) eq '/')
  {
    open(FH, '<', $conf->{'domain'})
      or croak('Unable to open domain-file: '.$!);
    my $newdom = (split(/ /, <FH>))[0];
    close(FH);
    croak("Unable to read domain-file. Maybe empty file.")
      if (!$newdom);
    chomp($newdom);
    $conf->{'domain'} = $newdom;
  }
 
  # generate signatures
  my $types = (ref($conf->{'types'}) eq 'ARRAY') ? $conf->{'types'} : [ $conf->{'types'} ];
  foreach my $type (@$types)
  {
    if ($type eq 'dkim')
    {
      $signer->add_signature(
        new Mail::DKIM::Signature(
          Algorithm  => $conf->{'algorithm'} || $signer->algorithm,
          Method     => $conf->{'method'}    || $signer->method,
          Headers    => $conf->{'headers'}   || $signer->headers,
          Domain     => $conf->{'domain'}    || $signer->domain,
          Selector   => $conf->{'selector'}  || $signer->selector,
          Query      => $conf->{'query'},
          Identity   => $conf->{'identity'},
          Expiration => $conf->{'expiration'}
        )
      );
    }
    elsif ($type eq 'domainkey')
    {
      $signer->add_signature(
        new Mail::DKIM::DkSignature(
          Algorithm  => 'rsa-sha1', # only rsa-sha1 supported
          Method     => $conf->{'method'}   || $signer->method,
          Headers    => $conf->{'headers'}  || $signer->headers,
          Domain     => $conf->{'domain'}   || $signer->domain,
          Selector   => $conf->{'selector'} || $signer->selector,
          Query      => $conf->{'query'}
        )
      );
    }
  }
 
  return 1;
}