#!/usr/bin/perl -w
#
#  chaffwin.pl: chaffing-and-winnowing encryption
#
#  usage: chaffwin.pl [ -e | -d ] passphrase [filename (or STDIN)]
#
#  ("-e" encrypts, "-d" decrypts)
#
#  See Ron Rivest's paper: http://theory.lcs.mit.edu/~rivest/chaffing.txt
#  See the file README for further instructions
#
#  Copyright (C) 1998 Ben Sussman and Karl Fogel
#  
#  This program is free software; you can redistribute it and/or
#  modify it under the terms of the GNU General Public License
#  as published by the Free Software Foundation; either version 2
#  of the License, or (at your option) any later version.
#  
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#  
#  You should have received a copy of the GNU General Public License along
#  with this program; if not, write to the Free Software Foundation, Inc.,
#  59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
#
#    Or contact the authors by electronic mail:
#     Ben Sussman <sussman@red-bean.com>
#     Karl Fogel  <kfogel@red-bean.com>
#    
############################################################

my $dictfile = "/usr/dict/words";

my $behavior;                # "-e" or "-d"
my $passphrase = "";         # default to "", why not?
my $filename;                # stdin if omitted
my $packets_per_group = 17;  # 17 is a default value

# Parse command-line arguments:
my $arg;
while ($arg = shift @ARGV)
{
  if ($arg eq "-e") {            # "-e" means we're encrypting
    $behavior = "encrypting";
  }
  elsif ($arg eq "-d") {         # "-d" means we're decrypting
    $behavior = "decrypting";
  }
  elsif ($arg eq "-c") {         # Chaff level: how many packets of chaff?
    $packets_per_group = shift @ARGV;
  }
  elsif ($arg eq "-p") {         
    $passphrase = shift @ARGV;
  }
  else {         
    $filename = $arg;
  }
}


# Sanity-check the chaff level:
if ($packets_per_group =~ /[^0-9]/) {
  die "Chaff level must be a positive integer.\n";
}


# todo: we need to randomize the salt, methinks.
# But see a "todo:" further down, in the decryption code --
# randomizing the salt would require non-trivial changes there.
my $salt = "bk";                    # 2-char "salt" for crypt()


# How much data does our hasher pay attention to?
# Note that you can't just go changing this according to your
# preference -- this number is part of the Unix crypt()
# implementation.  We hardcode it here only because there's no way
# to get it from the environment. 
my $crypt_significant_len = 8;


# Can't go very far without a passphrase, now, can we?
if (! defined ($passphrase)) {
  die ("no passphrase supplied");
}


#-----------------------------------------------------------
# Section I:  Dedicated to Random Word Generation (chaffing only)


# An array containing the most common 100 English words.
# According to one web page, these words make up 
# half of all written English!  I've added duplicates to create more
# statistical believability... more hits on "I", "you", "and", etc.

@commonwords = ("about", "after", "all", "am", "an", "and", "are",
"as", "at", "back", "be", "because", "been", "big", "but", "by",
"came", "can", "come", "could", "day", "did", "do", "down", "first",
"for", "from", "get", "go", "going", "got", "had", "has", "have",
"he", "her", "here", "him", "his", "I", "if", "in", "into", "is",
"it", "just", "like", "little", "look", "made", "make", "me", "more",
"my", "no", "not", "now", "of", "off", "on", "one", "only", "or",
"our", "out", "over", "said", "saw", "see", "she", "so", "some",
"that", "the", "their", "them", "then", "there", "they", "this", "to",
"two", "up", "very", "was", "we", "well", "went", "were", "what",
"when", "where", "which", "who", "will", "with", "would", "you",
"your", "and", "and", "and", "and", "I", "I", "I", "you", "you",
"you", "but", "but", "for", "for", "or", "or", "or", "to", "to", "to",
"to", "not", "not", "not", "was", "was", "we", "we", "it", "it", "it",
"it", "the", "the", "the", "the", "the", "the", "the", "the", "the",
"a", "a", "a", "a", "a", "a", "a");

sub random_commonword 
{
  my $line = $commonwords[(int (rand $#commonwords))];
  return $line;
}


# Subroutine to add random capitalization and punctutation to a word.

sub random_noise 
{
  my $bareword = shift(@_);
  my $randcap = int(rand(6));
  if ($randcap == 0) {         # 16% chance of capitialization
    $bareword =~ s/^(.)/uc($1)/e;
  }
  my $randcap2 = int(rand(5));
  if ($randcap2 == 0) {         # 20% chance of random punctuation
    my $randcap3 = int(rand(11));
    if ($randcap3 < 4) {      #   commas are most common
      $bareword = $bareword.",";	    
    }
    elsif ($randcap3 < 7) { #   then periods
      $bareword = $bareword.".";
    }
    elsif ($randcap3 == 7) { #   then !?""
      $bareword = $bareword."!";
    }
    elsif ($randcap3 == 8) {  
      $bareword = $bareword."?";
    }
    elsif ($randcap3 == 9) {   
      $bareword = $bareword."\\\"";
    }
    elsif ($randcap3 == 10) {   
      $bareword = "\\\"".$bareword;
    }
  }
  return $bareword;
}



# NEW: Subroutine to *match* captitalization/punctuation of wheatword!

sub copy_noise
{
    my $chaffword = shift;   # pass in the chaffword to modify
    my $wheatword = shift;   # pass the actual wheatword to mimic

    if ($wheatword eq ucfirst($wheatword)) # i.e. if it begins with uppercase
    {
	$chaffword =~ s/^(.)/uc($1)/e;     # force chaffword as well.	
    }
    else                     # it begins with lowercase,
    {
	$chaffword =~ s/^(.)/lc($1)/e;  # so must chaffword.
    }

    if ($wheatword =~ /\.$/) {   # if wheatword ends with a period...
	$chaffword .= ".";       # so must chaffword.
    }
    elsif ($wheatword =~ /,$/) {   # if wheatword ends with a comma...
	$chaffword .= ",";       # so must chaffword.
    }
    elsif ($wheatword =~ /!$/) {   # if wheatword ends with an exclamation...
	$chaffword .= "!";       # so must chaffword.
    }
    elsif ($wheatword =~ /\?$/) {   # if wheatword ends with a question mark...
	$chaffword .= "?";       # so must chaffword.
    }
    elsif ($wheatword =~ /\.$/) {   # if wheatword ends with a period...
	$chaffword .= ".";       # so must chaffword.
    }

    return $chaffword;
}




my @dictwords = ();  # dictionary cache
sub random_dictword 
{
    my $dictword = "";
    # Insure a full cache
    unless (@dictwords)
    {
      if (! open(DICT, "$dictfile"))
      {
        warn "Can't open $dictfile.  If you don't have $dictfile on\n"
            . "your system, please install the `words' file shipped with\n"
            . "this chaffwin distribution, and try again.\n"
            . "\n"
            . "In the meantime, chaffwin will attemp to use `./words'\n\n";

        close (DICT);
        open (DICT, "./words") or
            die ("Can't even open ./words\n\n*** ERROR (see above) ***\n\n");
      }

      while (<DICT>) {
        chomp;
        push @dictwords, ($_);
      }
      close(DICT);
    }
    
    # Choose a dictionary word that is *not* capitalized!
    # (proper nouns in the dictionary are a waste, and don't effectively
    #  "hide" the wheatword at all)

    do {
	$dictword = $dictwords[(int(rand $#dictwords)) + 1];
    } while ($dictword eq ucfirst($dictword));

    return $dictword;
}


#  The Grand Finale:  A subroutine that makes use of the previous
#  three, so as to create a random chaffword of the highest quality!

sub random_chaffword 
{
    my $wheatword = shift;    # passing this in so as to mimic its properties
    my $chaffword = "";
    my $random = int(rand(4));  # Chance of dictionary or common word
    if ($random < 3) {
	$chaffword = &random_commonword();
    }
    else {
	$chaffword = &random_dictword();
    }

    # COMMENTED OUT:  Random noise gives away too many clues!!
    # $chaffword = &random_noise($chaffword);  # And then add noise.

    # Instead, let's match properties of the wheatword:
    $chaffword = &copy_noise($chaffword, $wheatword);

    return $chaffword;
}


#----------------------------------------------------------------
# Section II:  Creates real and fake MACs.  (both chaffing and winnowing)

# We use a different phony passphrase each time to create fake MACs.
# It's always the same length as the real passphrase, to avoid
# an obvious cyphertext inspection attack.
my $seed = $passphrase;
sub random_passphrase ()
{
  while ($seed eq $passphrase) {
    substr ($seed, (rand (length $seed)), 1) = chr (rand (128));
  }
  return $seed;
}


sub make_MAC {
    my $cryptstring = shift;   # the word we're crypting
    my $some_passphrase = shift;   # either the real or fake passphrase

    $cryptstring .= $some_passphrase;

    # Break our new, longer string into ${crypt_significant_len}-char @chunks.

    my @in_chunks = ();                      # where to get chunks
    my @out_chunks = ();                     # where to put chunks

    # Divide $crypt_significant_len into strlen...
    my $mult = int((length $cryptstring)/$crypt_significant_len);
    # ... and save remainder:
    my $modlen = (length $cryptstring) % $crypt_significant_len;

    # Read $crypt_significant_len-byte chunks $mult times...
    for (my $ct = 0; $ct < $mult; $ct++) {
      push @in_chunks, substr ($cryptstring, 
                               ($ct * $crypt_significant_len), 
                               $crypt_significant_len);
    }
    # ... and possibly the remainder too:
    unless ($modlen == 0) {
      push @in_chunks, substr ($cryptstring, 
                               ($mult * $crypt_significant_len),
                               $modlen);
    }

    foreach $chunk (@in_chunks) {
	push @out_chunks, crypt($chunk, $salt);
    }
    
    my $longMAC = "";
    foreach $chunk (@out_chunks) {
	$longMAC .= $chunk;
    }

    return $longMAC;   # a concatenation of multiple crypts()
}

#----------------------------------------------------------------
# Section Q:  code I was too lazy to inline

sub escape_string ()
{
  my $escapeme = shift;
  $escapeme =~ s/\\/\\\\/gm;  # always escape the escaping-char first
  $escapeme =~ s/"/\\"/gm;    # double-quotes
  $escapeme =~ s/\n/\\n/gm;   # newlines
  return $escapeme;
}


sub unescape_string ()
{
  my $unescapeme = shift;
  # Don't try this at home, kids... at least, not in my home please!
  $unescapeme = eval "\"$unescapeme\"";
  return $unescapeme;

  # todo: or we could can do this by using `substr' as an lvalue in a
  # loop, I think, which might be a lot more efficient.  But not
  # nearly as much fun.  -karl
}


# Emit unless string is empty.  Return 1 if packet emitted, 0 if not.
sub emit_packet ()
{
  my $serial     = shift;
  my $str        = shift;
  my $passphrase = shift;   # might be real, might be fake

  # Return the amount to increment the serial number if nothing
  # emitted (i.e., don't increment):
  if ($str eq "") {
    return 0;
  }

  # Do backslash escaping
  $str = &escape_string ($str);

  my $len = length $str;

  my $MAC = &make_MAC($str.$serial, $passphrase);
  print "($serial, $len, \"$str\", $MAC)\n";
  
  # Return the amount to increment the serial number:
  return 1;
}


#----------------------------------------------------------------
# Section III:  Do it!  Encrypt or decrypt the message packets.

if ($behavior eq "encrypting")
{
  if ($filename) {
    open (FILE, "<$filename") or die ("can't open $filename");
  }
  else {
    open (FILE, "<&STDIN") or die ("can't open STDIN");
  }

  my $serial = 1;
  while (<FILE>)
  {
    # We do it this way for appearances -- nifty output is worth it!
    my ($non_ws_head, @non_whitespace) = split /\s+/, $_;  # Tokenize words
    my ($ws_head, @whitespace)         = split /\S+/, $_;  # Tokenize spaces


    # What's going on here?
    #
    # In essence: we sift the line into two arrays -- one containing
    # its non-whitespace stretches (i.e., the words, punctuation,
    # whatever), and the other containing the stretches of
    # whitespace.
    #
    # If whitespace starts the line, we emit the first element of
    # that array first; then, starting with the non-ws array, we
    # alternately emit an element at a time until both arrays are used
    # up.  That's all!
    #
    # As you can see, this was meant for textual data, although it
    # would "theoretically" work on binary files as well.


    # Include non-empty chunks, but ignore empty ones.
    # This is due to `split's behavior of producing empty strings
    # first in certain circumstances.
    if (defined ($non_ws_head) && ($non_ws_head ne "")) {
      unshift @non_whitespace, $non_ws_head;
    }
    if (defined ($ws_head) && ($ws_head ne "")) {
      unshift @whitespace, $ws_head;
    }

    # If line begins with whitespace, emit right now and move on:
    if (/^\s/) {
      $serial += &emit_packet ($serial, shift @whitespace, $passphrase);
    }

    for ($count = 0; $count <= $#non_whitespace; $count++) 
    {
      # Which packet will be the wheat:
      my $true_packet = int (rand ($packets_per_group));
      
      for ($cnt = 0; $cnt < ($packets_per_group); $cnt++) {
        if ($cnt == $true_packet) {
          &emit_packet ($serial, 
			$non_whitespace[$count], 
			$passphrase);
        }
        else {
          &emit_packet ($serial, 
			&random_chaffword($non_whitespace[$count]), 
			&random_passphrase());
        }
      }

      $serial++;
      print "\n";
      $serial += &emit_packet ($serial, shift @whitespace || "", $passphrase);
      print "\n";
    }
    print "\n";
  }
  close(FILE);
}
elsif ($behavior eq "decrypting")
{
  if ($filename) {
    open (FILE, "<$filename") or die ("can't open $filename");
  }
  else {
    open (FILE, "<&STDIN") or die ("can't open STDIN");
  }
    
  my $previous_serial = 0;
  while (<FILE>) 
  { 
    chomp;

    # Find one pair of parens on a line and remove them.
    if (/^\((.+)\)$/) 
    {
      my $message = $1;
      my $serial; 
      my $len;
      my $text; 
      my $hash;
      
      # Decompose the packet:
      $message =~ /([0-9]+), ([0-9]+), (.+)/;
      $serial = $1;
      $len    = $2;
      $text = substr ($3, 1, $len);  # compensate for leading double-quote
      $hash = substr ($3, $len + 4); # compensate for comma and space

      # todo: if we ever move to dynamic-salt, this code will break,
      # because it assumes all salts are the same as the initial salt:
      my $salt = substr($hash, 0, 2);
      
      # Break up extra-long MAC, then see if we reproduce the gigantic
      # MAC we recieved.  If we do, this is wheat, not chaff.

      my $teststring = $text.$serial.$passphrase;
      
      my @chunks = ();   # where to store the chunks

      # Divide $crypt_significant_len into strlen...
      my $mult = int((length $teststring)/$crypt_significant_len);

      # ... and save remainder:
      my $modlen = (length $teststring) % $crypt_significant_len;
      
      # Read ${crypt_significant_len}-byte chunks $mult times...
      for (my $ct = 0; $ct < $mult; $ct++) {
        push @chunks, substr ($teststring,
                              ($ct * $crypt_significant_len),
                              $crypt_significant_len);
      }

      # ... and possibly the remainder too:
      unless ($modlen == 0) {
        push @chunks, substr ($teststring,
                              ($mult * $crypt_significant_len),
                              $modlen);
      }
      
      # Run @chunks through crypt().
      # Isn't this a clever routine???
      # todo: and shouldn't it be unified with the chaffing encryption?

      foreach $chunk (@chunks) {
        my $temp = shift @chunks;
        push @chunks, crypt($temp, $salt);
      }
      
      my $longMAC = "";
      foreach $chunk (@chunks) {
        $longMAC .= $chunk;
      }
      
      if ($longMAC eq $hash) 
      {
        $text = &unescape_string ($text);
        print "$text";
      }

    }
  }

  close(FILE);
}
else 
{
  die "Don't recognize behavior \"${behavior}\"; exiting.\n";
}


### END chaffwin.pl ###
