use strict;
use Socket;
use IO::File;
use Sys::Hostname;
use Errno 'ENOENT';

sub handle_socks_proxyreq;
sub handle_http_proxyreq;
sub handle_smtp;

my ($clientproto,@chain);
my $hostname=hostname;
my ($ifile, $ofile, $maildir);
my ($i,$o);
my ($clientipstr, $serveripstr, $inport, $conntime);

sub stream2maildir
{
  @_==2 or die "Usage: stream2maildir(ifile, ofile)\n";

  ($ifile, $ofile)=@_;

  $i=IO::File->new($ifile) or die "$ifile: $!\n";
  $o=IO::File->new($ofile) or die "$ofile: $!\n";

  @chain=();

  my $base=$ifile;
  $base =~ s@.*/@@;
  $base =~ s@_i.*@@;
  $base =~ /^([^_]+)_([^_]+)_([^_]+)_([^_]+)_([^_]+)_([^_]+)$/
    or die "$ifile doesn't look like a tcpstream basename\n";
  ($clientipstr, $serveripstr, $inport, $conntime)=($1,$3,$4,$5);

  my $toport=handle_socks_proxyreq();
  if($toport==25) {
    handle_smtp();
  } elsif($toport==0) {
    # Proxy request failed, but in a clean way (with properly encoded failure
    # reply from the proxy). Do nothing here, just return.
  } else {
    die "Don't know what to do with connection to port $toport\n";
  }
}

sub doread
{
  my ($fh, $nbytes)=@_;
  my $buf='';
  $!=0;
  my $read=$fh->read($buf, $nbytes);
  return undef if !defined($read) && $!;
  return $buf;
}

sub cliread
{
  return doread($i, @_);
}

sub servread
{
  return doread($o, @_);
}

sub printlog
{
  print @_, "\n";
}

sub socks5_addrport
{
  my ($fh, $name)=@_;
  my $atyp=doread($fh, 1);
  if(!defined($atyp) || length($atyp)!=1) {
    die "error reading $name: $!\n";
  }
  $atyp=ord($atyp);
  my $host;
  if($atyp==1) {
    my $hostraw=doread($fh, 4);
    if(!defined($hostraw) || length($hostraw)!=4) {
      die "error reading $name: $!\n";
    }
    $host=inet_ntoa($hostraw);
  } elsif($atyp==3) {
    my $hostlen=doread($fh, 1);
    if(!defined($hostlen) || length($hostlen)!=1) {
      die "error reading $name: $!\n";
    }
    $hostlen=ord($hostlen);
    $host=doread($fh, $hostlen);
    if(!defined($host) || length($host)!=$hostlen) {
      die "error reading $name: $!\n";
    }
  } else {
    die "unsupported socks address type ".ord($atyp)." in $name\n";
  }
  my $portraw=doread($fh, 2);
  if(!defined($portraw) || length($portraw)!=2) {
    die "error reading $name: $!\n";
  }
  my $port=unpack("n", $portraw);
  return ($host,$port);
}

sub eofcheck
{
  my $desc=$_[0];
  if(!$i->eof()) {
    die "client didn't stop sending after $desc\n";
  }
  if(!$o->eof()) {
    die "server didn't stop sending after $desc\n";
  }
}

sub smtpreply
{
  my $cmd=$_[0];
  my $ret='';
  while(1) {
    $_=$o->getline();
    if(!defined($_)) {
      die "error reading SMTP response to $cmd: premature EOF\n";
    }
    $ret.=$_;
    last if /^\d\d\d /;
  }
  return $ret;
}

# Chooses a filename, opens tmp/filename as MAILDIRFILE, and returns the
# filename
my $mdmsgnum;
sub maildir_start_delivery
{
  my ($msgnum, $recvtime)=@_;
  $mdmsgnum ||= 0;
  ++$mdmsgnum;
  my $maildirfile="$recvtime.${$}_$mdmsgnum.$hostname";
  for my $attempt (1..10) {
    last if !stat("tmp/$maildirfile") && $! == ENOENT;
    if($attempt==10) {
      $maildirfile=undef;
      last;
    }
    sleep(2);
  }
  if(!$maildirfile) {
    die "msg $msgnum: couldn't get a file in $maildir/tmp\n";
  }
  # TODO: The Maildir specification requires a 24-hour death timer to
  # start here, for safe cleanup (any tmp file older than 1 day can be
  # deleted).
  if(!open(MAILDIRFILE, ">tmp/$maildirfile")) {
    die "failed writing to $maildir/tmp/$maildirfile: $!\n";
  }
  return $maildirfile;
}

# Take an arbitrary string and mangle it until it meets the RFC2821
# definition of a Domain (suitable for use in the Received header).
sub domain
{
  my $domain=$_[0];
  # Domain = (sub-domain 1*("." sub-domain)) / address-literal
  if($domain =~ /^\[(\d+)\.(\d+)\.(\d+)\.(\d+)\]\z/ &&
     $1<256 && $2<256 && $3<256 && $4<256) {
    # It's an IPv4 address-literal
    return $domain;
  }
  if($domain =~ /^\[IPv6(?::[0-9a-fA-F]{1,4}){8}\]\z/) {
    # It's an IPv6 address-literal in IPv6-full format
    return $domain;
  }
  IPV6_COMP: {
    last IPV6_COMP if $domain !~ /^\[IPv6:(.*)::(.*)\]\z/;
    my ($before, $after) = ($1, $2);
    last IPV6_COMP if $before =~ /::/ || $before =~ /^:/ || $before =~ /:$/ ||
                      $after =~ /::/  || $after =~ /^:/  || $after =~ /:$/;
    my @before=split /:/, $before;
    my @after=split /:/, $after;
    last IPV6_COMP if @before+@after > 6;
    for my $ipv6_hex (@before, @after) {
      last IPV6_COMP if $ipv6_hex !~ /^[0-9a-fA-F]{4}\z/;
    }
    # It's an IPv6 address-literal in IPv6-comp format
    return $domain
  }
  if($domain =~
     /^\[IPv6(?::[0-9a-fA-F]{1,4}){6}:(\d+)\.(\d+)\.(\d+)\.(\d+)\]\z/ &&
     $1<256 && $2<256 && $3<256 && $4<256) {
    # It's an IPv6 address-literal in IPv6v4-full format
    return $domain;
  }
  IPV6V4_COMP: {
    last IPV6V4_COMP if $domain !~
                        /^\[IPv6:(.*)::(|.+:)(\d+)\.(\d+)\.(\d+)\.(\d+)\]\z/ ||
                        $3>255 || $4>255 || $5>255 || $6>255;
    my ($before, $after) = ($1, $2);
    $after =~ s/:$//;
    last IPV6V4_COMP if $before =~ /::/ || $before =~ /^:/ || $before =~ /:$/ ||
                        $after =~ /::/  || $after =~ /^:/  || $after =~ /:$/;
    my @before=split /:/, $before;
    my @after=split /:/, $after;
    last IPV6V4_COMP if @before+@after > 4;
    for my $ipv6_hex (@before, @after) {
      last IPV6V4_COMP if $ipv6_hex !~ /^[0-9a-fA-F]{4}\z/;
    }
    # It's an IPv6 address-literal in IPv6v4-comp format
    return $domain
  }

  # Not an address-literal, hope it's a (sub-domain 1*("." sub-domain))
  my @sub_domains=split /\./, $domain, -1;
  # sub-domain = Let-dig [Ldh-str]
  my $good=1;
  for my $sub_domain (@sub_domains) {
    if($sub_domain !~ /^[A-Za-z0-9](?:[-A-Za-z0-9]*[A-Za-z0-9])\z/) {
      $good=0;
      last;
    }
  }
  return $domain if $good;

  # It's invalid. We must mangle it. Cover up all the bad spots with
  # underscores. Since underscore itself is an illegal character, the result
  # will still not be a valid domain, but it'll be close enough. Underscores
  # in domain names are a common mistake, so MUAs need to be prepared to
  # handle them. The underscores can therefore be considered a gentle hint
  # that there was a more complex forgery attempted. Look in the main log.
  for (@sub_domains) {
    s/^(-+)/'_' x length($1)/e;
    s/(-+)\z/'_' x length($1)/e;
  }
  $domain=join '.', @sub_domains;
  $domain =~ s/^(\.+)/'_' x length($1)/e;
  $domain =~ s/(\.+)\z/'_' x length($1)/e;
  $domain =~ s/(\.+)\./('_' x length($1)).'.'/ge;
  $domain =~ s/[^-A-Za-z0-9\.]/_/g;
  return $domain;
}

# Take an arbitrary string and apply quoting if necessary to meet the RFC2822
# definition of an addr-spec (suitable for use in the Return-Path header, and
# some other places). If the given address has no domain, just return it as
# an RFC2822 local-part.
sub addrspec
{
  my $addr_spec=$_[0];

  # addr-spec = local-part "@" domain
  my ($local_part, $domain);
  if($addr_spec =~ /(.*)\@(.*)/s) {
    ($local_part, $domain)=($1, $2);
  } else {
    ($local_part, $domain)=($addr_spec, undef);
  }

  # local-part      =       dot-atom / quoted-string / obs-local-part
  # dot-atom        =       [CFWS] dot-atom-text [CFWS]
  # dot-atom-text   =       1*atext *("." 1*atext)
  if($local_part =~ /[^^a-zA-Z0-9!#\$\%&'*+-\/=?_`{|}~.]/ ||
     $local_part =~ /^\./ ||
     $local_part =~ /\.$/ ||
     $local_part =~ /\.\./) {
    # Not a dot-atom, hope it's a quoted-string.
    # qcontent        =       qtext / quoted-pair
    # quoted-string   =       [CFWS]
    #                         DQUOTE *([FWS] qcontent) [FWS] DQUOTE
    #                         [CFWS]
    # (Approximating CFWS and FWS both as \s)
    if($local_part !~ /^\s*"(?:\s*(?:[^\s"\\]|\\[^\r\n\0\200-\377]))*"\s*$/) {
      # Not a quoted-string either, we have an invalid (or obsolete)
      # local-part. Mangle it to something reasonable.
      $local_part =~ s/^\s*//;
      $local_part =~ s/\s*$//;
      if($local_part !~ s/^\s*"(.*)"\s*$/$1/) {
        $local_part =~ s/\s//g;
      }
      $local_part =~ s/([\s"\200-\377\\])/\\$1/g;
      $local_part = qq/"$local_part"/;
    }
  }

  return $local_part if !defined($domain);

  # domain          =       dot-atom / domain-literal / obs-domain
  if($domain =~ /[^^a-zA-Z0-9!#\$\%&'*+-\/=?_`{|}~.]/ ||
     $domain =~ /^\./ ||
     $domain =~ /\.$/ ||
     $domain =~ /\.\./) {
    # Not a dot-atom, hope it's a domain-literal.
    # domain-literal  =       [CFWS] "[" *([FWS] dcontent) [FWS] "]" [CFWS]
    # dcontent        =       dtext / quoted-pair
    # (Approximating CFWS and FWS both as \s)
    if($domain !~ /^\s*\[(?:\s*[^\s\[\]\\]|\\[^\r\n\0\200-\377])*\s*\]\s*$/) {
      # Not a domain-literal either, we have an invalid (or obsolete)
      # domain. Mangle it to something reasonable.
      $domain=domain($domain);
    }
  }
  return "$local_part\@$domain";
}

my $strftime_percent_z_ok;
BEGIN
{
  # I want strftime(%z), which is supported by POSIX::strftime if the
  # system's libc supports it (Linux does, others don't), or by
  # Date::Format::strftime if that module is installed (it is not part of the
  # perl distribution). This sets up a strftime() function which accepts 2
  # args (like the first 2 args of Date::Format::strftime), and sets
  # $strftime_percent_z_ok to true if %z will be recognized.

  # Try Date::Format first
  eval {
    require Date::Format;
  };
  if(!$@) {
    *strftime=sub { Date::Format::strftime($_[0], $_[1]) };
    $strftime_percent_z_ok=1;
    return;
  }

  *strftime=sub { POSIX::strftime($_[0], @{$_[1]}) };
  # Try POSIX::strftime. Behavior on an unrecognized format character is
  # undocumented, so assume the worst: it might throw an exception.
  my $zone='';
  eval {
    $zone=POSIX::strftime("%z", localtime());
  };
  if(!$@ && $zone =~ /^[-+]?\d+/) {
    $strftime_percent_z_ok=1;
    return;
  }

  # D'oh!
  $strftime_percent_z_ok=0;
}

# Return an unambiguous single-line ASCII representation of an arbitrary string
sub cleanstr
{
  my $s=$_[0];
  my $l=length($s);
  my $ret='"';
  my $i;
  for($i=0;$i<$l;++$i) {
    my $c=substr($s, $i, 1);
    my $cc=ord($c);
    if($c eq "\n") {
      $ret .= "\\n";
    } elsif($c eq "\t") {
      $ret .= "\\t";
    } elsif($c eq "\r") {
      $ret .= "\\r";
    } elsif($cc < 32 || $cc > 126) {
      my $nextc=substr($s, $i+1, 1);
      if($nextc =~ /\d/) {
        $ret .= "\\".sprintf("%03o", $cc);
      } else {
        $ret .= "\\".sprintf("%o", $cc);
      }
    } elsif($c eq "\\" || $c eq '"') {
      $ret .= "\\".$c;
    } else {
      $ret .= $c;
    }
  }
  $ret .= '"';
  return $ret;
}

sub localdate822
{
  my $now=$_[0];
  # RFC2822 declares the %Z timezone names obsolete, so we only use it here
  # if %z is unavailable. We really do want the real local time zone here,
  # because it might be used for reporting the client to abuse@wherever
  my $zone=$strftime_percent_z_ok ? '%z' : '%Z';
  return strftime("%a, %d %b %Y %H:%M:%S $zone", [localtime($now)]);
}

sub localheader
{
  my ($helo, $esmtp, $msgnum, $rpath, $rcpts, $recvtime)=@_;
  my $ret="Return-Path: <".addrspec($rpath).">\n";
  $ret.="Delivered-To: <".addrspec($_).">\n" for @$rcpts;
  $helo=gethostbyaddr(inet_aton($clientipstr), AF_INET) if !defined $helo;
  $helo="MISSING-HELO" if !defined $helo; # TODO: use alternate Received
                                          # line format for this case
  # TODO: include reverse DNS of the client
  $ret.="Received: from ".domain($helo).
        " ([$clientipstr]) by $serveripstr\n";
  my $e=$esmtp?'E':'';
  # "via" shows the only initial protocol, not the whole chain
  my $via = uc($clientproto);
  my $id = "$$,$recvtime"; # TODO: This is not good.
  $ret.="          with ${e}SMTP via $via ($inport) id \"$id,$msgnum\"";
  $ret.="\n          (attempted proxy to $_->{destip}:$_->{destport})"
    for @chain;
  $ret.=";\n          ".localdate822($recvtime)."\n";
  return $ret;
}

sub smtp_data
{
  my ($helo, $esmtp, $msgnum, $rpath, $rcpts)=@_;
  $rpath="MISSING-MAIL-FROM" if !defined $rpath; # This should never happen
  printlog "msg $msgnum: DATA beginning";
  my $recvtime=$conntime; # TODO: get time from $i stream. Requires closer
                          # interaction with libpcap
  my $maildirfile=maildir_start_delivery($msgnum, $recvtime);
  if(!print MAILDIRFILE
            localheader($helo, $esmtp, $msgnum, $rpath, $rcpts, $recvtime)) {
    { local $!; unlink("tmp/$maildirfile"); }
    die "failed writing to $maildir/tmp/$maildirfile: $!\n";
  }
  my $bodyline;
  my $inlongline=0;
  while(defined($bodyline=$i->getline())) {
    last if $bodyline =~ /^\.\r?\n/;
    $bodyline =~ s/^\.//;
    $bodyline =~ s/\r\n/\n/g;
    if(!print MAILDIRFILE $bodyline) {
      { local $!; unlink("tmp/$maildirfile"); }
      die "failed writing to $maildir/tmp/$maildirfile: $!\n";
    }
  }
  if(!defined($bodyline) && $!) {
    { local $!; unlink("tmp/$maildirfile"); }
    die "msg $msgnum: error reading message body: $!\n";
  } elsif(!defined($bodyline) || !length($bodyline)) {
    unlink("tmp/$maildirfile");
    die "msg $msgnum: premature EOF reading message body\n";
  }
  printlog "msg $msgnum: DATA completed";
  if(smtpreply('end of DATA') !~ /^2/) {
    printlog "msg $msgnum: rejected after end of DATA";
    unlink("tmp/$maildirfile");
    return;
  }
  # The Maildir specification requires an fsync here. Seems like that would
  # be going overboard.
  if(!close(MAILDIRFILE)) {
    { local $!; unlink("tmp/$maildirfile"); }
    die "failed writing to $maildir/tmp/$maildirfile: $!\n";
  } elsif(!link("tmp/$maildirfile", "new/$maildirfile")) {
    { local $!; unlink("tmp/$maildirfile"); }
    die "msg $msgnum: couldn't link to $maildir/new/$maildirfile: $!\n";
  } else {
    printlog "msg $msgnum: delivered as $maildirfile";
  }
  unlink("tmp/$maildirfile");
}

sub handle_smtp
{
  printlog "starting SMTP session";
  if(smtpreply('initial connect (banner)') !~ /^2/) {
    printlog "server gave unfriendly banner";
    eofcheck('unfriendly SMTP banner');
    return;
  }

  my $cmd;
  my $msgnum=0;
  my ($seenmailfrom,$seenrcptto)=(undef,[]);
  my $helo;
  my $esmtp=0;
  while(defined($cmd=$i->getline())) {
    $cmd =~ s/\r?\n\z/\r\n/;
    if($cmd =~ /^\s*HELO\s+([ -~]*?)\r\n/i) {
      my $arg=$1;
      if(smtpreply('HELO') =~ /^2/) {
        $helo=$arg;
        printlog "client HELO name: ".cleanstr($helo);
      } else {
        printlog "rejected client HELO name: ".cleanstr($arg);
      }
    } elsif($cmd =~ /^\s*EHLO\s+([ -~]*?)\r\n/i) {
      my $arg=$1;
      if(smtpreply('EHLO') =~ /^2/) {
        $helo=$arg;
        $esmtp=1;
        printlog "client EHLO name: ".cleanstr($helo);
      } else {
        printlog "rejected client EHLO name: ".cleanstr($arg);
      }
    } elsif($cmd =~ /^\s*MAIL FROM\s*:\s*<?([ -~]*?)\s*>?\s*\r\n/i) {
      my $arg=$1;
      if(smtpreply('MAIL FROM') =~ /^2/) {
        ++$msgnum;
        printlog "starting new message $msgnum with MAIL FROM:<".
                 cleanstr($arg).">";
        ($seenmailfrom,$seenrcptto)=($arg,[]);
      } else {
        printlog "rejected MAIL FROM: <".cleanstr($arg).">";
      }
    } elsif($cmd =~ /^\s*RCPT TO\s*:\s*<?([ -~]*?)\s*>?\s*\r\n/i) {
      my $arg=$1;
      if(smtpreply('RCPT TO') =~ /^2/) {
        if(!defined($seenmailfrom)) {
          ++$msgnum;
          printlog "starting new message $msgnum with no MAIL FROM";
          ($seenmailfrom,$seenrcptto)=('',[]);
        }
        printlog "msg $msgnum: recipient RCPT TO:<".cleanstr($arg).">";
        push(@$seenrcptto, $arg);
      } else {
        printlog "rejected RCPT TO: <".cleanstr($arg).">";
      }
    } elsif($cmd =~ /^\s*DATA\s*\r\n/i) {
      if(smtpreply('DATA') =~ /^3/) {
        if(!defined($seenmailfrom)) {
          die "server accepted DATA without MAIL FROM\n";
        } elsif(!@$seenrcptto) {
          die "server accepted DATA without RCPT TO\n";
        } else {
          smtp_data($helo, $esmtp, $msgnum, $seenmailfrom, $seenrcptto);
          ($seenmailfrom,$seenrcptto)=(undef,[]);
        }
      } else {
        if(!defined($seenmailfrom) || !@$seenrcptto) {
          printlog "out-of-order DATA (rejected by server)";
        } else {
          printlog "msg $msgnum: DATA command rejected by server";
          ($seenmailfrom,$seenrcptto)=(undef,[]); # TODO: Is this right?
        }
      }
    } elsif($cmd =~ /^\s*RSET\s*\r\n/i) {
      if(smtpreply('RSET') =~ /^2/) {
        if(defined($seenmailfrom)) {
          printlog "msg $msgnum: cancelled by RSET";
        } else {
          printlog "useless RSET";
        }
        ($seenmailfrom,$seenrcptto)=(undef,[]);
      } else {
        printlog "rejected RSET";
      }
    } elsif($cmd =~ /^\s*QUIT\s*\r\n/i) {
      smtpreply('QUIT');
      if(defined($seenmailfrom)) {
        printlog "msg $msgnum: cancelled by QUIT";
      } else {
        printlog "QUIT request from client";
      }
      last;
    } else {
      smtpreply('non-message command');
      my $logcmd=$cmd;
      $logcmd =~ tr/\r\n//d;
      printlog "non-message command: $logcmd";
    }
  }
  printlog "ending session";
  eofcheck('end of SMTP session');
}

sub handle_socks_proxyreq
{
  my $ver=cliread(1);
  if(!defined($ver) || length($ver)!=1) {
    die "error reading socks request from client: $!\n";
  }
  if(ord($ver)==5) {
    printlog "receiving socks version 5 request";
    my $nmethods=cliread(1);
    if(!defined($nmethods) || length($nmethods)!=1) {
      die "error reading socks request from client: $!\n";
    }
    $nmethods=ord($nmethods);
    my $methods=cliread($nmethods);
    if(!defined($methods) || length($methods)!=$nmethods) {
      die "error reading socks request from client: $!\n";
    }
    printlog "client offered authentication methods: ".
             join(" ", map { ord($_) } split //, $methods);
    $ver=servread(1);
    if(!defined($ver) || length($ver)!=1) {
      die "error reading socks reply from proxy: $!\n";
    }
    if(ord($ver)!=5) {
      die "proxy switched from socks5 to unsupported version ".ord($ver)."\n";
    }
    my $method=servread(1);
    if(!defined($method) || length($method)!=1) {
      die "error reading socks reply from proxy: $!\n";
    }
    $method=ord($method);
    printlog "proxy requested authentication method $method";
    if($method==0) {
      # nothing
    } elsif($method==2) {
      $ver=cliread(1);
      if(!defined($ver) || length($ver)!=1) {
        die "error reading socks request from client: $!\n";
      }
      if(ord($ver)!=1) {
        die "client used unsupported socks userpass ".
            "authentication version ".ord($ver)."\n";
      }
      my $ulen=cliread(1);
      if(!defined($ulen) || length($ulen)!=1) {
        die "error reading socks request from client: $!\n";
      }
      $ulen=ord($ulen);
      my $username=cliread($ulen);
      if(!defined($username) || length($username)!=$ulen) {
        die "error reading socks request from client: $!\n";
      }
      my $plen=cliread(1);
      if(!defined($plen) || length($plen)!=1) {
        die "error reading socks request from client: $!\n";
      }
      $plen=ord($plen);
      my $password=cliread($plen);
      if(!defined($password) || length($password)!=$plen) {
        die "error reading socks request from client: $!\n";
      }
      printlog "client sent username ".cleanstr($username).
               " with password ".cleanstr($password);
      $ver=servread(1);
      if(!defined($ver) || length($ver)!=1) {
        die "error reading socks userpass auth reply from proxy: $!\n";
      }
      if(ord($ver)!=1) {
        die "proxy switched from socks userpass auth version 1 to version ".ord($ver)."\n";
      }
      $ver=servread(1);
      if(!defined($ver) || length($ver)!=1) {
        die "error reading socks userpass auth reply from proxy: $!\n";
      }
      if(ord($ver)!=0) {
        printlog "proxy rejected client's socks userpass authentication";
        eofcheck('failed proxy authentication');
        return 0;
      }
    } elsif($method==255) {
      printlog "proxy will not accept any authentication method from client";
      eofcheck('failed proxy authentication');
      return 0;
    } else {
      die "Don't know what to do with socks5 auth method $method";
    }
    # auth done. now read connection request
    # Kludge: Some spamware is sending an extra \0 at the end of the method
    # list. And some trojan proxy is ignoring that extra \0. So that's what
    # we do here, if the request version byte is a \0 instead of a \5.
    for my $try (1,2) {
      $ver=cliread(1);
      if(!defined($ver) || length($ver)!=1) {
        die "error reading socks request from client: $!\n";
      }
      last if ord($ver)==5;
      next if ord($ver)==0 && $try==1; # Try again, dumbass
      die "client switched from socks5 to unsupported version ".
          ord($ver)."\n";
    }
    my $cmd=cliread(1);
    if(!defined($cmd) || length($cmd)!=1) {
      die "error reading socks request from client: $!\n";
    }
    if(ord($cmd)!=1) {
      die "client tried to use unsupported socks command ".
          ord($cmd)."\n";
    }
    my $rsv=cliread(1);
    if(!defined($rsv) || length($rsv)!=1) {
      die "error reading socks request from client: $!\n";
    }
    my ($host,$port)=socks5_addrport($i, 'socks request from client');
    printlog "client requested connection to $host:$port";
    $ver=servread(1);
    if(!defined($ver) || length($ver)!=1) {
      die "error reading socks reply from proxy: $!\n";
    }
    if(ord($ver)!=5) {
      die "proxy switched from socks5 to unsupported version ".ord($ver)."\n";
    }
    my $rep=servread(1);
    if(!defined($rep) || length($rep)!=1) {
      die "error reading socks reply from proxy: $!\n";
    }
    $rep=ord($rep);
    if($rep!=0) {
      printlog "proxy rejected connection request: ".
               ($rep==1 ? "general SOCKS server failure" :
                $rep==2 ? "connection not allowed by ruleset" :
                $rep==3 ? "Network unreachable" :
                $rep==4 ? "Host unreachable" :
                $rep==5 ? "Connection refused" :
                $rep==6 ? "TTL expired" :
                $rep==7 ? "Command not supported" :
                $rep==8 ? "Address type not supported" :
                "Error $rep");
      my $igrsv=servread(1);
      if(!defined($igrsv) || length($igrsv)!=1) {
        die "error reading socks reply from proxy: $!\n";
      }
      socks5_addrport($o, 'socks reply from proxy');
      eofcheck('failed proxy request');
      return 0;
    }
    $rsv=servread(1);
    if(!defined($rsv) || length($rsv)!=1) {
      die "error reading socks reply from proxy: $!\n";
    }
    my ($bindhost,$bindport) = socks5_addrport($o, 'socks reply from proxy');
    printlog "connection succeeded with bound address $bindhost:$bindport";
    push(@chain, { destip=>$host, destport=>$port });
    $clientproto='SOCKS5';
    return $port;
  } elsif(ord($ver)==4) {
    printlog "receiving socks version 4 request";
    my $cd=cliread(1);
    if(!defined($cd) || length($cd)!=1) {
      die "error reading socks request from client: $!\n";
    }
    if(ord($cd)!=1) {
      die "client tried to use unsupported socks command ".ord($cd)."\n";
    }
    my $portraw=cliread(2);
    if(!defined($portraw) || length($portraw)!=2) {
      die "error reading socks request from client: $!\n";
    }
    my $port=unpack("n", $portraw);
    my $hostraw=cliread(4);
    if(!defined($hostraw) || length($hostraw)!=4) {
      die "error reading socks request from client: $!\n";
    }
    my $host=inet_ntoa($hostraw);
    my $user='';
    while(1) {
      my $c=cliread(1);
      if(!defined($c) || length($c)!=1) {
        die "error reading socks request from client: $!\n";
      }
      last if $c eq "\0";
      $user.=$c;
    }
    printlog "client requested connection to $host:$port with username ".
              cleanstr($user);
    # TODO: socks 4A - if $host is 0\.0\.0\.\d+, read a NUL-terminated hostname
    $ver=servread(1);
    if(!defined($ver) || length($ver)!=1) {
      die "error reading socks reply from proxy: $!\n";
    }
    if(ord($ver)!=0) {
      die "proxy reponded to socks4 request with reply version ".ord($ver)."\n";
    }
    $cd=servread(1);
    if(!defined($cd) || length($cd)!=1) {
      die "error reading socks reply from proxy: $!\n";
    }
    $cd=ord($cd);
    if($cd!=90) {
      printlog "proxy rejected connection request: ".
               ($cd==91 ? "request rejected or failed" :
                $cd==92 ? "identd failure" :
                $cd==93 ? "identd reports different username" :
                "Error $cd");
      my $ighostport=servread(6);
      if(!defined($ighostport) || length($ighostport)!=6) {
        die "error reading socks reply from proxy: $!\n";
      }
      eofcheck('failed proxy request');
      return 0;
    }
    my $ighostport=servread(6);
    if(!defined($ighostport) || length($ighostport)!=6) {
      die "error reading socks reply from proxy: $!\n";
    }
    printlog "connection succeeded";
    push(@chain, { destip=>$host, destport=>$port });
    $clientproto='SOCKS4';
    return $port;
  } else {
    if($ver =~ /[A-Za-z]/) {
      $i->seek(-1, 1) or die "seek($ifile): $!\n";
      return handle_http_proxyreq();
    }
    die "client tried to use unsupported socks version ".ord($ver)."\n";
  }
}

sub log_lines_until_blank
{
  my ($fh, $label)=@_;
  my $s='';
  my $line;
  while(defined($line=$fh->getline()) && length($line)) {
    last if $line =~ /^\r?\n\z/;
    $s.=$line;
  }
  if(!defined($line) || !length($line)) {
    return undef;
  }
  printlog "$label: ".cleanstr($s) if length($s);
  return $s;
}

sub handle_http_proxyreq
{
  my $request=$i->getline();
  if(!defined($request)) {
    die "error reading HTTP command from client: $!\n";
  }
  if(!length($request)) {
    die "EOF from client\n";
  }
  printlog "received HTTP command from client: ".
           cleanstr($request);
  if($request !~ /^CONNECT ([-.a-zA-Z0-9]+):(\d+)(?: ?\/)? HTTP\/1\.[01]\r?\n/)
  {
    die "Don't know what to do with command ".cleanstr($request)."\n";
  }
  my ($host, $port) = ($1, $2);
  printlog "client requested connection to $host:$port";
  if(!defined(log_lines_until_blank($i, 'request headers'))) {
    die "HTTP request incomplete\n";
  }

  my $reply=$o->getline();
  if(!defined($reply)) {
    die "error reading HTTP response from proxy: $!\n";
  }
  if(!length($reply)) {
    die "EOF from client\n";
  }
  printlog "received HTTP response from proxy: ".
           cleanstr($reply);
  if($reply !~ /^HTTP\/1\.[01] (\d)\d\d [^\r\n]*\r?\n\z/)
  {
    die "Invalid HTTP proxy response ".cleanstr($reply)."\n";
  }
  if($1!=2) {
    printlog "proxy rejected connection request";
    if(!defined(log_lines_until_blank($o, 'reply headers'))) {
      die "HTTP reply incomplete\n";
    }
    eofcheck('failed proxy request');
    return 0;
  }
  printlog "connection succeeded";
  if(!defined(log_lines_until_blank($o, 'reply headers'))) {
    die "HTTP reply incomplete\n";
  }
  $clientproto='HTTP';
  return $port;
}

my $port;
sub tcpstream_init
{
  @_==2 && $_[0] =~ /^\d+$/ or die
    "Usage: $0 inputfile outdir backend stream2maildir port maildir\n";
  ($port, $maildir)=@_;
  -d $maildir or mkdir($maildir, 0777) or die "$maildir: $!\n";
  -d "$maildir/new" or mkdir("$maildir/new", 0777) or die "$maildir/new: $!\n";
  -d "$maildir/cur" or mkdir("$maildir/cur", 0777) or die "$maildir/cur: $!\n";
  -d "$maildir/tmp" or mkdir("$maildir/tmp", 0777) or die "$maildir/tmp: $!\n";
  chdir($maildir) or die "chdir($maildir): $!\n";
}

# This tcpstream callback does SOCKS+SMTP->maildir analysis on the requested
# port and then removes the stream files.
sub tcpstream_callback
{
  if($_[0] !~ /_[^_]*_[^_]*_${port}_[^_]*_[^_]*_i/) {
    unlink $_[0], $_[1], $_[2];
    return;
  }
  print STDERR "Processing $_[0]\n";
  eval { stream2maildir($_[0], $_[2]); };
  if($@) {
    warn $@;
  } else {
    unlink $_[1];
  }
  unlink $_[0], $_[2];
}

1;