#!/usr/bin/perl

# You are free to use this program for any purpose.
# Author: Bruno Wolff III
# Last changed: May 27, 2001

# Where the script, Roll.pm, .pgp keyring directory and temp file space are.
BEGIN {$home = '/some_absolute_path'};

BEGIN {unshift(@INC, $home)};
use Roll;
use MIME::Parser;
use PGP::Sign;
use Mail::Address;
use IO::Handle;
use Net::SMTP;
use Time::CTime;

# Make PGP key ring location independent of who runs this program.
$PGP::Sign::PGPPATH = $home . '/.pgp';

# Use the directory where the script is located for tmp files.
$PGP::Sign::TMPDIR = $home;

# This doesn't count the newline. Any more causes quoted printable to
# insert line breaks.
$maxline = 69;

# Maximum number of rolls.
$maxrolls = 30000;

# Maximum amount of entropy in bits
$maxentropy = 30000;

# Maximum number of recipients. This discourages using the die roller as
# an email amplifier.
$maxrec = 10;

# Maximum size of message reply. This stops some kinds of mail bombing.
$maxsize = 200000;

# Maximum number of sides on a die roll.
$maxsides = 1000000000000;

sub addreply {
  my $i;
  foreach $i (@_) {
    if ($size > $maxsize) {
    }
    elsif ($size + length($i) > $maxsize) {
      push(@reply, "\nMessage too long (> $maxsize characters).\n");
      push(@reply, "No further Die rolls will be made.\n");
      push(@reply, "Further text will be truncated.\n\n");
      $error = 1;
      $size = $maxsize + 1;
    }
    else {
      $size += length($i);
      push(@reply, $i);
    }
  }
}
  
$pass = 'Your passphrase goes here';
Mail::Header->mail_from('COERCE');
$full = 'Your keyid goes here <address@example.com>';
@i = Mail::Address->parse($full);
$me = $i[0]->address;
$meuser = $i[0]->user;
$parser = new MIME::Parser;
$parser->output_to_core('ALL');
$entity = $parser->read(\*STDIN);
$entity->head->unfold;
@to = $entity->head->get_all('to');
push(@to, $entity->head->get_all('cc'));
push(@to, $entity->head->get_all('resent-to'));
push(@to, $entity->head->get_all('resent-cc'));
push(@to, $entity->head->get_all('bcc'));
push(@to, $entity->head->get_all('resent-bcc'));
@from = $entity->head->get_all('from');
push(@from, $entity->head->get_all('resent-from'));
push(@from, $entity->head->get_all('sender'));
push(@from, $entity->head->get_all('resent-sender'));
push(@from, $entity->head->get_all('reply-to'));
push(@from, $entity->head->get_all('resent-reply-to'));
@received = $entity->head->get_all('received');
$subject = $entity->head->get('subject', 0);
$osub = $subject;
$subject =~ s/^re: //i;
$id = $entity->head->get('message-id', 0);
$date = $entity->head->get('date', 0);
$gmt = strftime("%a, %d %b %Y %T -0000 (GMT)", gmtime);

@head = ();
foreach $head (@received) {
  push(@head, 'Received: ' . $head);
}
push(@head, 'Subject: ' . $osub);
push(@head, '');
foreach $head (@from) {
  chop $head;
  $head[-1] .= ', ' . $head;
}
$head[-1] =~ s/^, //;
$head[-1] = 'From: ' . $head[-1];
push(@head, '');
foreach $head (@to) {
  chop $head;
  $head[-1] .= ', ' . $head;
}
$head[-1] =~ s/^, //;
$head[-1] = 'To: ' . $head[-1];
push(@head, 'Message-ID: ' . $id);
push(@head, 'Date: ' . $date);
push(@head, '');

$from = '';
foreach $add (@from) {
  @i = Mail::Address->parse($add);
  foreach $i (@i) {
    exit 0 if $i->user =~ /^(|postmaster|mail(er)?-daemon)$/i;
    exit 0 if $i->address =~ /^($meuser|$me)$/i;
    $from = $i;
  }
}
exit(0) unless $from;

%add = ();
$tome = 0;
foreach $add (@to, @from) {
  @i = Mail::Address->parse($add);
  foreach $i (@i) {
    next if $i->user =~ /^(|postmaster|mail(er)?-daemon)$/i;
    if ($i->address =~ /^($meuser|$me)$/i) {$tome = 1; next;}
    $add{$i->address} = 1;
  }
}
exit 0 unless $tome;

$error = 0;
$size = 0;
@reply = ();

$i = scalar keys %add;
if ($i > $maxrec) {
  $to = $from;
  $error = 1;
  addreply("\nToo many recipients ($i > $maxrec) were specified.\n");
  addreply("No rolls will be made.\n\n");
}
else {
  $to = join(', ', sort keys %add);
}

$reply = build MIME::Entity
  Type => 'multipart/signed; micalg=pgp-md5; protocol="application/pgp-signature"',
  -Subject => "Re: $subject",
  -From => $me,
  -To => $to,
  -In-Reply-To => $id,
  -Date => $gmt;


foreach $r (@head) {
  $r = '> ' . $r;
  $r =~ s/\s/ /g;
  $r =~ s/ +$//;
  while (length($r) > $maxline) {
    $t = substr($r, 0, $maxline);
    $t =~ s/ +$//;
    addreply($t, "\n");
    $r = '+ ' . substr($r, $maxline);
  }
  addreply($r, "\n");
}
undef @head;

$anyrolls = 0;
@ents = $entity;
while (scalar(@ents)) {
  $e = pop(@ents);
  (push(@ents, reverse($e->parts)), next) if $e->is_multipart;
  next unless $e->mime_type eq 'text/plain' || $e->mime_type eq 'text';
  $IO = $e->bodyhandle->open('r');
  while (defined($r = $IO->getline) && $size <= $maxsize) {
    $r = '> ' . $r;
    $r =~ s/\s/ /g;
    $r =~ s/ +$//;
    $d = '';
    if ($r =~ /#/) {
      if ($r =~ /^> #(\d+)(,\d+|)(!?)(-\d+|)(=?)$/) {
        if ($error) {
          $d = "\nDie roll skipped due to previous error.\n\n";
        }
        else {
          $n = $1;
          $s = $2;
          $u = $3;
          $t = $4;
          $e = $5;
          $n =~ s/^0*(\d)/\1/;
          $s =~ s/^,0*(\d)/\1/;
          $t =~ s/^-0*(\d)/\1/;
          $s = 6 if $s eq '';
          if (length($n) > length($maxrolls) || $n + $anyrolls > $maxrolls) {
            $d = "\nOnly $maxrolls dice can be rolled in one message.\nNo further die rolls will be done in this message.\n\n";
            $error = 1;
          }
          elsif (length($s) > length($maxsides) || $s < 1 || $s > $maxsides) {
            $d = "\nThe number of sides must be from 1 to $maxsides.\nNo further die rolls will be done in this message.\n\n";
            $error = 1;
          }
          elsif ((log($s)/log(2))*$n + entropy > $maxentropy) {
            $d = "\nThe maximum allowed amount of entropy use is $maxentropy bits.\nNo further die rolls will be done in this message.\n\n";
            $error = 1;
          }
          elsif ($u eq '!' && $n > $s) {
            $d = "\nThe number of unique rolls requested must be less than or equal to the\nnumber of sides on the dice.\nNo further die rolls will be done in this message.\n\n";
            $error = 1;
          }
          else {
            if ($t eq '') {
              $sum = 0;
              $d = "\nRoll:";
              $i = 4;
              if ($u eq '!') {
                @roll = nUm($n,$s);
              }
              else {
                @roll = nDm($n,$s);
              }
              $anyrolls += $n;
              foreach $roll (@roll) {
                $sum += $roll;
                $j = "  $roll";
                if ($i + length($j) > $maxline) {
                  $d .= "\n    ";
                  $i = 4;
                }
                $d .= $j;
                $i += length($j);
              }
              if ($e eq '=') {
                $j = "  Sum: $sum";
                if ($i + length($j) > $maxline) {
                  $d .= "\n    ";
                  $i = 4;
                }
                $d .= $j;
                $i += length($j);
              }
              $d .= "\n\n";
              $d =~ s/ //;
            }
            else {
              if ($t > $s || $t < 1) {
                $d = "\nThe hit check number must be 1 to $s.\nNo further die rolls will be done in this message.\n\n";
                $error = 1;
              }
              else {
                $sum = 0;
                $d = "\nRoll:";
                $i = 4;
                if ($u eq '!') {
                  @roll = nUm($n,$s);
                }
                else {
                  @roll = nDm($n,$s);
                }
                $anyrolls += $n;
                foreach $roll (@roll) {
                  $sum += $roll;
                  $j = "  $roll";
                  if ($i + length($j) > $maxline) {
                    $d .= "\n    ";
                    $i = 4;
                  }
                  $d .= $j;
                  $i += length($j);
                }
                $hits = hits($t, @roll);
                if ($hits == 0) {
                  $j = "  (No hits)";
                }
                elsif ($hits == 1) {
                  $j = "  (1 hit)";
                }
                else {
                  $j = "  ($hits hits)";
                }
                if ($i + length($j) > $maxline) {
                  $d .= "\n    ";
                  $i = 4;
                }
                $d .= $j;
                $i += length($j);
                if ($e eq '=') {
                  $j = "  Sum: $sum";
                  if ($i + length($j) > $maxline) {
                    $d .= "\n    ";
                    $i = 4;
                  }
                  $d .= $j;
                  $i += length($j);
                }
                $d .= "\n\n";
                $d =~ s/ //;
              }
            }
          }
        }
      }
      else {
        $d = "\nIncorrectly formatted die roll request. Use: #digits,digits!-digits=\nNo further die rolls will be done in this message.\n\n";
        $error = 1;
      }
    }
    while (length($r) > $maxline) {
      $t = substr($r, 0, $maxline);
      $t =~ s/ +$//;
      addreply($t, "\n");
      $r = '+ ' . substr($r, $maxline);
    }
    addreply($r, "\n");
    addreply($d) if $d;
  }
  $IO->close;
}
undef($e);
undef($entity);
if ($anyrolls == 0) {
  addreply <<"EOF" ;

Since your message did not successfully request any die rolls you are
being sent this brief help message.

This die rolling service is primarily intended to be used for play by
mail Titan games. For the time being other use is OK, but I may have
to limit it in the future.

To use this service send an email message to $me
and the other players who need to witness the roll. In the message
include comments describing what the rolls are for.  Any line not
staring with a # will be treated as a comment.

Die roll requests have the following formats:
#number_of_dice,number_of_sides!-minimum_number_to_count=

Only one of these may appear on the line. No imbedded whitespace is
allowed. The number of sides defaults to 6 if the comma and number of
sides is left off. If the - and minimum number to count is left off,
no hit count is provided. A trailing = requests the sum of the rolls
to be printed. The ! requests unique rolls and is normally omitted.

Examples:

To roll 9 6-sided dice, counting 4s, 5s and 6s as hits, use:
#9-4
or
#9,6-4

To roll 10 100-sided dice use:
#10,100

To roll 8 5-sided dice and count 3s, 4s and 5s as hits, use:
#8,5-3

To roll 2 6-sided dice and get their sum use:
#2=

To roll 3 unique values of from 6 sided dice use:
#3!

There are some limits on the number of die rolls and the message
size.

See http://wolff.to/dice/ for more details.
EOF
}
else {
  $i = int((entropy+7)/8);
  if ($i <= 0) {
    addreply "\nNo entropy was used in making your die rolls.\n";
  }
  elsif ($i == 1) {
    addreply "\n1 byte of entropy was used to make your die rolls.\n";
  }
  else {
    addreply "\n$i bytes of entropy were used to make your die rolls.\n";
  }
}

$reply->attach (
  Type => 'text/plain; charset=us-ascii',
  Encoding => 'quoted-printable',
  Disposition => 'inline',
  -Subject => "Re: $subject",
  -From => $me,
  -To => $to,
  -In-Reply-To => $id,
  -Date => $gmt,
  Data => \@reply);

$IO = new IO::Scalar \$print;
($reply->parts)[0]->head->print($IO);
$IO->print("\n");
$BH = ($reply->parts)[0]->bodyhandle->open('r');
$encode = new MIME::Decoder 'quoted-printable';
$encode->encode($BH, $IO);
$IO->seek(0, 0);
$IO1 = new IO::Scalar \$print1;
while (defined($r = $IO->getline)) {
  chop $r;
  $IO1->print("$r\r\n");
}
($sign, $ver) = pgp_sign($full, $pass, $print1);
undef $IO1, $print1;
$sign = "-----BEGIN PGP SIGNATURE-----\nVersion: $ver\n\n$sign\n-----END PGP SIGNATURE-----\n";
attach $reply
  Type => 'application/pgp-signature',
  Encoding => '7bit',
  Disposition => 'attachment',
  Data => $sign;

$print = '';
$IO->seek(0, 0);
$reply->print($IO);
$m = new Net::SMTP;
$m->mail("$me");
foreach $t (keys %add) {
  $m->to("$t");
}
$m->data;
$m->datasend($print);
$m->dataend;
$m->quit;