#!/usr/bin/perl -w
# Copyright © 2001 Jamie Zawinski <jwz@dnalounge.com>
#
# Permission to use, copy, modify, distribute, and sell this software and its
# documentation for any purpose is hereby granted without fee, provided that
# the above copyright notice appear in all copies and that both that
# copyright notice and this permission notice appear in supporting
# documentation.  No representations are made about the suitability of this
# software for any purpose.  It is provided "as is" without express or 
# implied warranty.
#
# Created: 13-Sep-2001.
#
# Usage:
#    Assuming your sendmail is configured to deliver all unknown addresses
#    to the same place, add this to /etc/aliases:
#
#        unknown-address: "|/etc/smrsh/bounce.pl -"
#
#    In that way, you get to both customize your bounce messages, and also,
#    have all bounces BCCed to a local user, for debugging.
#
#    Be sure to edit $local_domain before installing this.


require 5;
use diagnostics;
use strict;

my $progname = $0; $progname =~ s@.*/@@g;
my $version = q{ $Revision: 1.6 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;

my $verbose = 0;


my $local_domain  = "dnalounge.com";
my $bounce_bcc    = undef;
my $sendmail      = "/usr/sbin/sendmail";
my $sendmail_args = "-t -fMAILER-DAEMON";

my $text_footer =
  ("Please check the address and try again.  If you are still\n".
   "having problems, check the web site for contact info:\n" .
   "\n" .
   "    http://www.$local_domain/\n" .
   "\n" .
   "Thank you.  Drive through.\n\n"
  );

my $text_footer_kiosk_kludge =
  ("You are probably getting this bounce because you replied to\n" .
   "a message sent from one of the public web kiosks here at the\n" .
   "DNA Lounge nightclub in San Francisco.\n" .
   "\n" .
   "To reply, you'll have to read the body of the original\n" .
   "message for any clues the author may have left you as to\n" .
   "their identity.  Users of our terminals are anonymous, and\n" .
   "are not authenticated in any way.\n" .
   "\n" .
   "Please report any abuse to Postmaster\@dnalounge.com.\n" .
   "\n" .
   "    http://www.$local_domain/\n" .
   "\n" .
   "Thank you.  Drive through.\n"
  );



sub error {
  ($_) = @_;
  print STDERR "$progname: $_\n";
  exit 1;
}

sub make_text_part {
  ($_) = @_;
  my ($user, $host) = m/^([^@]+)@(.*)$/;
  if (! (defined($host) && defined($user) && $user ne '' && $host ne '')) {
    error "not a fully qualified email addr: $_";
  }

  my $footer = $text_footer;

  if ($user =~ m/^(kiosk|guest)/i &&
      $host =~ m/dnalounge/i) {
    $footer = $text_footer_kiosk_kludge;
  }

  return ("Your message could not be delivered:\n" .
          "\n" .
          "    User \"$user\" does not exist at $local_domain.\n" .
         "\n" .
          $footer);
}

sub make_dsn_part {
  my ($addr) = @_;
  return ("Reporting-MTA: dns; $local_domain\n" .
          "\n" .
          "Final-Recipient: RFC822; $addr\n" .
          "Action: failed\n" .
          "Status: 5.1.1\n" .
          "Diagnostic-Code: SMTP; 550 <$addr>... User unknown\n");
}


sub mime_pack {
  my (@args) = @_;
  my $body = "";
  my $mp_type = shift @args;

  my $boundary = sprintf ("%08x.%08x%08x",
                          time(), rand(0xFFFFFF), rand(0xFFFFFF));

  $body .= "Content-Type: $mp_type; boundary=\"$boundary\"\n";
  $body .= "Auto-Submitted: auto-generated (failure)\n";
  $body .= "\n";
  $body .= "This is a MIME-encapsulated message.\n";

  while ($#args >= 0) {
    my $type = shift @args;
    my $part = shift @args;

    $body .= "\n--$boundary\n";
    $body .= "Content-Type: $type\n" if (defined($type) && $type ne '');
    $body .= "\n";
    $body .= $part;
  }

  $body .= "\n--$boundary--\n";

  return $body;
}


sub make_bounce_body {
  my ($addr, $orig_msg) = @_;
  return mime_pack ("multipart/report",
                    "",                        make_text_part ($addr),
                    "message/delivery-status", make_dsn_part ($addr),
                    "message/rfc822",          $orig_msg);
}


sub make_bounce {
  my ($file) = @_;
  my $body = "";
  local *IN;
  open (IN, "<$file") || error ("reading $file: $!");
  print STDERR "$progname: reading \"$file\"\n" if ($verbose);
  while (<IN>) { $body .= $_; }
  close IN;

  my $mail_from;
  my $rcpt_to;

  if ($body =~ m/^From ([^,; \t\r\n<>]+) [^\n]+\n(.*)$/s) {
    $mail_from = $1;
    $body = $2;
    print STDERR "$progname: MAIL FROM:<$mail_from>\n" if ($verbose);
  } else {
    error ("no From_ envelope on message?");
  }

  my $headers;
  if ($body =~ m/^(.*?)\n\r?\n/s) {
    $headers = $1;
  } else {
    error ("no blank line for end of headers?");
  }

  $headers =~ s/\n[ \t]+/ /gm;  # unwrap header lines
  if ($headers =~ m/^Received: .*\bfor <?([^ \t\r\n<>;]+)>?;/im) {
    $rcpt_to = $1;
    if (! ($rcpt_to =~ m/[@]/)) {
      $rcpt_to .= "\@$local_domain";
    }
    print STDERR "$progname: RCPT TO:<$rcpt_to>\n" if ($verbose);
  } else {
    error ("no obvious recipient in Received headers?")
  }

  my $unknown_user = $rcpt_to;
  $unknown_user =~ s/@.*$//;
  $unknown_user .= "\@$local_domain";

  my $msg = ("From: MAILER-DAEMON\@$local_domain\n" .
             "To: $mail_from\n" .
             ($bounce_bcc ? "BCC: $bounce_bcc\n" : "") .
             "Subject: Returned Mail: User unknown ($unknown_user)\n" .
             make_bounce_body ($rcpt_to, $body));

  if ($verbose > 1) {
    $_ = $msg;
    s/^/$progname: >>> /gm;
    print STDERR $_;
  }

  return $msg;
}

sub bounce {
  my ($file, $stdout_p) = @_;
  my $msg = make_bounce ($file);
  if ($stdout_p) {
    print STDOUT $msg;
  } else {
    deliver ($msg);
  }
}

sub deliver {
  my ($msg) = @_;

  print STDERR "$progname: mailing bounce\n" if ($verbose);
  local *PIPE;
  open (PIPE, "|$sendmail $sendmail_args") || error ("$sendmail: $!");
  print PIPE $msg;
  close (PIPE) || error ("$sendmail: $!");
}


sub usage {
  print STDERR "usage: $progname [--verbose] [--stdout] msg-file\n";
  exit 1;
}

sub main {
  my $in = undef;
  my $stdout_p = 0;
  while ($_ = $ARGV[0]) {
    shift @ARGV;
    if ($_ eq "--verbose") { $verbose++; }
    elsif ($_ eq "--stdout") { $stdout_p++; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    elsif (m/^-./) { usage; }
    elsif (!defined($in)) { $in = $_; }
    else { usage; }
  }
  usage() unless defined($in);
  bounce ($in, $stdout_p);
}

main;
exit 0;