#!/usr/bin/perl -w
# Copyright © 2000 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: 18-Aug-00.
#
# This script opens a connection to the SMTP port on localhost, and relays
# between it and stdin, after doing some translation and logging.  The idea
# here is that this script runs on some port on the mail server, and the
# firewall redirects all SMTP connections from the kiosk subnet to that
# port.  This prevents forgery of mail from that entire network.
#
# The changes this script makes are:
#
#  - The SMTP "MAIL FROM" address and the contents of the "From:" header
#    are rewritten to contain a fixed email address ($def_sender).
#
#  - An X-Authentication-Warning header is added to the message announcing
#    that it was sent anonymously.
#
#  - The whole transaction can be logged, optionally including message bodies.
#
# Command line options:
#   -v, -vv, -vvv for verbosity on STDERR;
#   -l, -ll, -lll for level of logging in the $log_file.


require 5;
use diagnostics;
use strict;

############################################################################
############################################################################
#
# Customize these:
#
my $log_file = "/var/log/kiosklog";
my $def_sender  = "kiosk\@dnalounge.net";
my $def_headers =
  "X-Authentication-Warning: This message was sent anonymously\n" .
  "	from a public web kiosk at the DNA Lounge nightclub\n" .
  "	in San Francisco (http://www.dnalounge.com/).\n" .
  "	The sender has not been authenticated in any way.\n" .
  "	Please report any abuse to Postmaster\@dnalounge.com.\n";
#
############################################################################
############################################################################

use Socket;
use POSIX qw(strftime);
use Fcntl ':flock'; # import LOCK_* constants

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

my $verbose = 0;  # 0 = none, 1 = write everything to stderr
my $logging = 0;  # 0 = none, 1 = smtp cmds, 2 = smtp responses, 3 = msg bodies


my $state;             # state machine:
my $state_smtp   = 0;  #  smtp commands
my $state_header = 1;  #  header section of message payload
my $state_body   = 2;  #  body section of message payload


my $log_data = "";

# Write a line to the log file if appropriate.
# line types are: 0 = smtp command; 1 = smtp response; 2 = message body.
#
sub log_line {
  my ($lines, $type) = @_;
  return unless $logging;
  return if ($type == 2 && $logging < 3);
  return if ($type == 1 && $logging < 2);
  my $date = strftime ("%b %d %T", localtime);
  my $prefix = ($type == 1 ? "<<< " : $logging < 2 ? "    " : ">>> ");
  foreach (split(/\n/, $lines)) {
    s/\r$//;
    $log_data .= "$date $progname\[$$\]: $prefix$_\n";
  }
}

# Write the log data to the file all at once, at the end of the session.
# This is so we don't hold the file locked for very long, so that a session
# going catatonic doesn't deny service to others.  The other alternative
# would be to open/lock/unlock/close the log file at every line of the SMTP
# session, but that seems like a lot of overhead.
#
sub flush_log_data {
  return if ($log_data eq "");

  if (! open (LOG, ">>$log_file")) {
    print STDERR "$progname: error opening $log_file: $!\n";
    return;
  }

  if (! flock (LOG, LOCK_EX)) {
    print STDERR "$progname: error locking $log_file: $!\n";
#    close LOG;
#    return;
  }

  print LOG $log_data;
  $log_data = "";

  print STDERR "$progname: logged to $log_file\n" if $verbose;

  flock (LOG, LOCK_UN) ||
    print STDERR "$progname: error unlocking $log_file: $!\n";

  close LOG ||
    print STDERR "$progname: error closing $log_file: $!\n";
}


# Opens a connection to the given server/port, and leaves it in the
# file descriptor <SMTP>.
#
sub open_smtp {
  my ($host, $port) = @_;

  my ($remote, $iaddr, $paddr, $proto, $line);
  if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
  $port || die "$progname: getservbyname($port, 'tcp')";
  $iaddr = inet_aton($host) || die "$progname: inet_aton($host)";
  $paddr = sockaddr_in($port, $iaddr);

  $proto = getprotobyname('tcp');
  socket(SMTP, PF_INET, SOCK_STREAM, $proto) || die "$progname: socket: $!\n";
  connect(SMTP, $paddr) || die "$progname: connect($host:$port): $!\n";

  select(SMTP); $| = 1; select(STDOUT);

  print STDERR "$progname: connected to $host:$port\n" if $verbose;

  $state = $state_smtp;
}


# Constructs a valid message ID based on $def_sender.
#
sub make_message_id {
  srand;
  $def_sender =~ m/(\@[^\@]*)$/;
  return "<" .
         sprintf ("%08X.", time()) . sprintf ("%08X", int(rand(0xFFFFFF))) .
         $1 . ">";
}

# Constructs an RFC 822 date.
#
sub make_date {
  return strftime ("%a, %d %b %Y %T %z", localtime);
}

# Constructs a Received header describing this hop of message delivery.
#
sub make_received_line {
  my ($helo) = @_;

  my $name;
  my $addr;

  my $sockaddr = getpeername (STDIN);
  if ($sockaddr) {
    my ($port, $iaddr) = unpack_sockaddr_in($sockaddr);
    $name = gethostbyaddr ($iaddr, AF_INET);
    $addr = inet_ntoa($iaddr);
  }

  $name = "unknown" unless $name;
  $addr = "unknown" unless $addr;
  my $date = make_date();
  my $uname = `uname -n`;
  $uname =~ s/\n$//;
  my $localaddr = gethostbyname($uname);
  my $localhost = gethostbyaddr($localaddr, AF_INET);
  $localaddr = inet_ntoa ($localaddr);

  return "Received: from $helo ($name [$addr])\n" .
    "        by $uname ($localhost [$localaddr]);\n" .
    "        $date\n";
}


# Rewrite an RFC 822 addr-spec so that $def_sender is the address part.
# Any other names or addresses that were there before are left in the
# comment part.  This doesn't handle any complicated variations: if 
# there is anything funny about the pre-existing name/address, they
# just get tossed.
#
sub rewrite_addr {
  my ($addr_spec) = @_;

  my ($name, $addr);
  if ($addr_spec =~ m/^([^<>]*)<([^>]+)>([^<>]*)$/) {       # name <addr>
    $name = $1 . $3;
    $addr = $2;
  } elsif ($addr_spec =~ m/^([^()]*)\(([^>]+)\)[ \t]*$/) {  # addr (name)
    $name = $2;
    $addr = $1;
  } elsif ($addr_spec =~ m/^([^()<>]+)$/) {                 # addr
    $name = "";
    $addr = $1;
  } else {
    $name = "";
    $addr = "";
  }

  if (! ($addr =~ m/^$def_sender$/i)) {
    if ($name eq "") {
      $name = $addr;
    } else {
      $name .= " ($addr)";
    }

    $addr = $def_sender;

    # strip out double-quotes in the name
    $name =~ s/\"//g;

    # the name needs to be enclosed in quotes if it contains special chars,
    # including at-signs and parentheses.
    $name = "\"$name\"" if ($name =~ m/[^-_A-Za-z0-9 \t]/);
  }

  if ($name eq "") {
    $addr_spec  = $addr;
  } else {
    $addr_spec = "$name <$addr>";
  }

  $addr_spec =~ s/[ \t][ \t]+/ /g;

  return $addr_spec;
}

# Given a multi-line block of message headers, this cleans them up by
# making sure there is exactly one From, Date, Message-ID, etc.  It 
# also rewrites the return addresses to match $def_sender.
#
sub rewrite_headers {
  my ($helo, $headers) = @_;
  $helo = "unknown" unless $helo;

  my ($from, $sender, $to, $cc, $id, $date, $recv, $others);
  $others = "";
  $recv = "";

  # canonicalize linebreaks
  $headers =~ s/\r\n/\n/g;
  $headers =~ s/\r/\n/g;

  # horrible kludge to iterate over headers with continuation lines
  $headers =~ s/\001/ /gs;
  $headers =~ s/\n+$//gs;
  $headers =~ s/\n([^ \t])/\001$1/gs;

  foreach (split (/\001/, $headers)) {
    my ($field, $body) = m/^([^ \t\n:]+)[ \t]*:[ \t]*(.*)/s;
    next unless ($field && $body);

    if ($field =~ m/^From$/i) {
      $from = $body;
    } elsif ($field =~ m/^Sender$/i) {
      $sender = $body;
    } elsif ($field =~ m/^Message-ID$/i) {
      $id = $body;
    } elsif ($field =~ m/^Date$/i) {
      $date = $body;
    } elsif ($field =~ m/^To$/i) {
      if ($to) {
        $to = "$to, $body";
      } else {
        $to = $body;
      }
    } elsif ($field =~ m/^CC$/i) {
      if ($to) {
        $cc = "$cc, $body";
      } else {
        $cc = $body;
      }
    } elsif ($field =~ m/^Received$/i) {
      $recv .= "$field: $body\n";
    } else {
      $others .= "$field: $body\n";
    }
  }

  $others = "" unless $others;
  $others .= $def_headers;

  $from   = $def_sender unless $from;
  $sender = $def_sender unless $sender;
  $date   = make_date() unless $date;
  $id     = make_message_id() unless $id;
  $recv = "" unless $recv;

  $from   = rewrite_addr ($from);
  $sender = rewrite_addr ($sender);
  $recv   = make_received_line ($helo) . $recv;

  $headers = "";
  $headers .= $recv;
  $headers .= "Date: $date\n";
  $headers .= "Sender: $sender\n";
  $headers .= "From: $from\n";
  $headers .= "To: $to\n" if $to;
  $headers .= "Cc: $cc\n" if $cc;
  $headers .= "Message-ID: $id\n";
  $headers .= "$others";

  # re-canonicalize linebreaks
  $headers =~ s/\n/\r\n/g;

  return $headers;
}


# Writes the given line to <SMTP>, after munging it.
# This tracks the state of the session, and rewrites certain lines,
# like "MAIL FROM".  It also gathers together the outer RFC822
# headers and filters them through rewrite_headers().
#
my $helo = undef;
my $headers = "";
sub process_line {
  my ($line) = @_;

  my $ostate = $state;

  if ($state == $state_smtp && $line =~ m/^DATA[\r\n]/) {
    $state = $state_header;
  } elsif ($state == $state_header && $line =~ m/^[\r\n]/) {
    $state = $state_body;

    # fix the headers
    $headers = rewrite_headers ($helo, $headers);

    # flush out the cached headers
    print SMTP $headers;

    log_line ($headers, 2);

    if ($verbose) {
      foreach (split(/\n/, $headers)) {
        print STDERR "$progname: .>> $_\n" if $verbose;
      }
    }

  } elsif ($state == $state_smtp && $line =~ m/^MAIL FROM:/i) {
    # unconditionally overwrite the envelope line.
    # (This loses the "SIZE=" option, if it was present;
    # I doubt that matters.)
    $line = "MAIL FROM:<$def_sender>\r\n";

  } elsif ($state == $state_smtp && $line =~ m/^(HELO|EHLO)\s+([^\s]+)/i) {
    # remember who they said they are
    $helo = $2;

  } else {

    if ($state == $state_header) {
      $headers .= $line;
      return;
    }
  }

  print STDERR "$progname: >>> $line" if $verbose;
  print SMTP $line;

  log_line ($line, ($ostate >= $state_header ? 2 : 0));
}


# Read a line from STDIN, write, it to SMTP via process_line(),
# and then wait for a response.  If the line is the SMTP "DATA" 
# command, then read and process the whole body of that command,
# since the response only comes at the end.
#
# Warning: this assumes that all SMTP commands except DATA are
# single line, single response.
# 
sub read_cmd {
  my $cmd = <STDIN>;
  return undef unless $cmd;
  $cmd =~ s/\r?\n$//s;

  process_line "$cmd\r\n";

  if ($cmd eq "DATA") {
    return unless read_reply();
    while (<STDIN>) {
      s/\r?\n$//s;
      process_line "$_\r\n";
      if ($_ eq ".") {
        $state = $state_smtp;
        last;
      }
    }
  }

  return $cmd;
}


# Read and return a reply from <SMTP>.
# Handles multi-line responses.
# If its reply code is 221, then return undef (meaning EOF).
#
sub read_reply {
  my ($banner_p) = @_;
  while (1) {
    my $reply = <SMTP>;
    return undef unless $reply;
    $reply =~ s/\r?\n$//s;
    $reply =~ s@^(220 [^\s]+ [^\s]+)@$1 $progname/$version;@ if $banner_p;
    print STDERR "$progname: <<< $reply\n" if $verbose;
    print STDOUT "$reply\r\n";

    log_line ($reply, 1);

    return undef if ($reply =~ m/^221 /);   # fucking hack...

    return $reply unless ($reply =~ m/^\d\d\d-/);  # cont line
  }
}

# Read commands from STDIN and replies from SMTP, until EOF.
#
sub main_loop {
  return unless read_reply 1;  # get banner
  while (1) {
    last unless read_cmd;
    last unless read_reply;
  }

  close SMTP;
  close STDIN;
  flush_log_data;
}


my $usage = "usage: $progname [--verbose] [--log]\n";

sub main {

  while ($_ = $ARGV[0]) {
    shift @ARGV;
    if ($_ eq "-verbose") { $verbose++; }
    elsif ($_ eq "-log") { $logging++; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    elsif (m/^-l+$/) { $logging += length($_)-1; }
    elsif (m/^-/) { print STDERR $usage; exit 1; }
    else {
      print STDERR $usage; exit 1;
    }
  }

  open_smtp ("localhost", "smtp");
  main_loop;
}

main;
exit 0;