#!/usr/bin/perl -T

#------------------------------------------------------------------------------
# This is amavisd-release, an EXAMPLE quarantine release utility program.
# It uses AM.PDP protocol to send a request to amavisd daemon to release
# a quarantined mail message.
#
# Usage:
#   amavisd-release mail_file secret_id [alt_recip1 alt_recip2 ..]
#
# To be placed in amavisd.conf:
#   $interface_policy{'SOCK'} = 'AM.PDP';
#   $policy_bank{'AM.PDP'} = {protocol=>'AM.PDP'};
#   $unix_socketname='/var/amavis/amavisd.sock';
#or:
#   $interface_policy{'9998'} = 'AM.PDP';
#   $policy_bank{'AM.PDP'} = {protocol=>'AM.PDP'};
#   $inet_socket_port = [10024,9998];
#
# To obtain secret_id and quar_type belonging to some mail_id:
# $ mysql mail_log -e \
#   'select secret_id,quar_type,content from msgs where mail_id="W+7uJyXUjw32"'
#
# If secret_id is not available, administrator may choose to skip checking
# of secret_id in the amavisd daemon by setting a configuration variable
# $auth_required_release to false (it defaults to true). If the release
# client program specifies a nonempty secret_id in the request, the secret_id
# will be validated and a request will fail if not valid, regardless of the
# setting of $auth_required_release. Turning off a requirement for a valid
# secret_id widens the right to release to anyone who can connect to amavisd
# socket (Unix or inet). Access to the socket therefore needs to be restricted
# using socket protection (unix socket) or @inet_acl (for inet socket).
#
# Author: Mark Martinec <mark.martinec@ijs.si>
# Copyright (C) 2005-2008  Mark Martinec,  All Rights Reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# * Redistributions of source code must retain the above copyright notice,
#   this list of conditions and the following disclaimer.
# * Redistributions in binary form must reproduce the above copyright notice,
#   this list of conditions and the following disclaimer in the documentation
#   and/or other materials provided with the distribution.
# * Neither the name of the author, nor the name of the "Jozef Stefan"
#   Institute, nor the names of contributors may be used to endorse or
#   promote products derived from this software without specific prior
#   written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
# OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
# ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
#(the license above is the new BSD license, and pertains to this program only)
#
# Patches and problem reports are welcome.
# The latest version of this program is available at:
#   http://www.ijs.si/software/amavisd/
#------------------------------------------------------------------------------

use warnings;
use warnings FATAL => 'utf8';
no  warnings 'uninitialized';
use strict;
use re 'taint';
use IO::Socket;
use Time::HiRes ();

use vars qw($VERSION);  $VERSION = 1.500;
use vars qw($log_level $socketname);

  $log_level = 1;
# $socketname = '127.0.0.1:9998';
  $socketname = '/var/lib/amavis/amavisd.sock';

sub sanitize_str {
  my($str, $keep_eol) = @_;
  my(%map) = ("\r" => '\\r', "\n" => '\\n', "\f" => '\\f', "\t" => '\\t',
              "\b" => '\\b', "\e" => '\\e', "\\" => '\\\\');
  if ($keep_eol) {
    $str =~ s/([^\012\040-\133\135-\176])/  # and \240-\376 ?
              exists($map{$1}) ? $map{$1} :
                     sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/eg;
  } else {
    $str =~ s/([^\040-\133\135-\176])/      # and \240-\376 ?
              exists($map{$1}) ? $map{$1} :
                     sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/eg;
  }
  $str;
}

sub do_log($$) {
  my($level, $errmsg) = @_;
  print STDERR sanitize_str($errmsg),"\n"  if $level <= $log_level;
}

sub proto_decode($) {
  my($str) = @_;
  $str =~ s/%([0-9a-fA-F]{2})/pack("C",hex($1))/eg;
  $str;
}

sub proto_encode($@) {
  my($attribute_name,@strings) = @_; local($1);
  $attribute_name =~    # encode all but alfanumerics, '_' and '-'
    s/([^0-9a-zA-Z_-])/sprintf("%%%02x",ord($1))/eg;
  for (@strings) {      # encode % and nonprintables
    s/([^\041-\044\046-\176])/sprintf("%%%02x",ord($1))/eg;
  }
  $attribute_name . '=' . join(' ',@strings);
}

sub ask_amavisd($$) {
  my($sock,$query_ref) = @_;
  my(@encoded_query) =
    map { /^([^=]+)=(.*)\z/s; proto_encode($1,$2) } @$query_ref;
  do_log(2,'> '.$_)  for @encoded_query;
  $sock->print( map { $_."\015\012" } (@encoded_query,'') )
    or die "Can't write response to socket: $!";
  $sock->flush or die "Can't flush on socket: $!";
  my(%attr);
  local($/) = "\015\012";    # set line terminator to CRLF
  # must not use \r and \n, which may not be \015 and \012 on certain platforms
  do_log(2,"waiting for response");
  while(<$sock>) {
    last  if /^\015\012\z/;  # end of response
    if (/^ ([^=\000\012]*?) (=|:[ \t]*) ([^\012]*?) \015\012 \z/xsi) {
      my($attr_name) = proto_decode($1);
      my($attr_val)  = proto_decode($3);
      if (!exists $attr{$attr_name}) { $attr{$attr_name} = [] }
      push(@{$attr{$attr_name}}, $attr_val);
    }
  }
  if (!defined($_) && $! != 0) { die "read from socket failed: $!" }
  \%attr;
}

sub release_file($$$@) {
  my($sock,$mail_file,$secret_id,@alt_recips) = @_;
  my($fn_path,$fn_prefix,$mail_id,$fn_suffix); local($1,$2,$3,$4);
  if ($mail_file =~ m{^ ([^/].*/)? ([A-Z0-9][A-Z0-9._-]*[_-])?
                        ([A-Z0-9][A-Z0-9_+-]{10}[A-Z0-9]) (\.gz)? \z}xsi) {
    ($fn_path,$fn_prefix,$mail_id,$fn_suffix) = ($1,$2,$3,$4);
  } elsif ($mail_file =~ m{^ ([^/].*/)? () ([A-Za-z0-9$._=+-]+?) (\.gz)?\z}xs){
    ($fn_path,$fn_prefix,$mail_id,$fn_suffix) = ($1,$2,$3,$4);  # old style
  } else {
    usage("Invalid quarantine ID: $mail_file");
  }
  my($quar_type) =
    $fn_suffix eq '.gz' ? 'Z'
    : $fn_path eq '' && $mail_id eq $mail_file ? 'Q' : 'F';
  my($request_type) = $0 =~ /\breport\z/i  ? 'report'
                    : $0 =~ /\brequeue\z/i ? 'requeue' : 'release';
  my(@query) = (
    "request=$request_type",
    "quar_type=$quar_type",
    "mail_id=$mail_id",
  );
  push(@query, "secret_id=$secret_id")  if $secret_id ne '';
  push(@query, "mail_file=$mail_file")  if $quar_type =~ /^[FZB]\z/;
  if (@alt_recips) {  # override original recipients if list is nonempty
    push(@query, map {"recipient=$_"} @alt_recips);
  }
  my($attr_ref) = ask_amavisd($sock,\@query);
  $attr_ref && %$attr_ref  or die "Invalid response received";
  for my $attr_name (keys %$attr_ref) {
    for my $attr_val (@{$attr_ref->{$attr_name}})
      { do_log(2,"< $attr_name=$attr_val") }
  }
  do_log(0,$_)  for (@{$attr_ref->{'setreply'}});
  # may do another release request on the same session if needed ...
}

sub usage(;$) {
  my($msg) = @_;
  print STDERR $msg,"\n\n"  if $msg ne '';
  my($prog) = $0;  $prog =~ s{^.*/(?=[^/]+\z)}{};
  print STDERR "$prog version $VERSION\n";
  die "Usage:  \$ $prog mail_file [secret_id [alt_recip1 alt_recip2 ...]]\n".
      "  or to read request lines from stdin:  \$ $prog -\n";
}

# Main program starts here

  my($sock,$mail_file,$secret_id);
  @ARGV >= 1 or usage("Not enough arguments");
  $mail_file = shift(@ARGV);   # quarantine file id or '-'
  if ($mail_file eq '-') { @ARGV==0 or usage("Extra arguments after '-'") }
  my($is_inet) = $socketname=~m{^/} ? 0 : 1; # simpleminded: unix vs. inet sock
  if ($is_inet) {   # inet socket
    $sock = IO::Socket::INET->new($socketname)
      or die "Can't connect to INET socket $socketname: $!";
  } else {          # unix socket
    $sock = IO::Socket::UNIX->new(Type => SOCK_STREAM)
      or die "Can't create UNIX socket: $!";
    $sock->connect( pack_sockaddr_un($socketname) )
      or die "Can't connect to UNIX socket $socketname: $!";
  }
  if ($mail_file eq '-') {
    undef $!;
    while (<>) {  # read from STDIN: mail_file [secret_id [alt_recips...]]
      chomp;
      next  if /^[ \t]*(#.*)?$/;  # skip empty lines or comments
      my($mail_file, $secret_id, @alt_recips) = split(' ');
      release_file($sock,$mail_file,$secret_id,@alt_recips);
    }
    $!==0 or die "Error reading from STDIN: $!";
  } else {
    # assume empty secret_id if the second arg looks like e-mail addr
    $secret_id = $ARGV[0]=~/\@/ ? '' : shift(@ARGV);
    release_file($sock,$mail_file,$secret_id,@ARGV);
  }
  $sock->close or die "Error closing socket: $!";
  close(STDIN) or die "Error closing STDIN: $!";