#!/usr/bin/perl -w
use strict;

#headerparse.pl
#(C) 2004-5 Silvestrisoft, by John B. Silvestri
#
#include <license/gpl.txt>

use Mail::Internet;
use Mail::Header;
use Mail::Field;
use Mail::Field::Received;
use Mail::Field::Date;
use Time::Duration;

my $input=shift @ARGV;
open INFILE, "<", "$input"
	or die ("Cannot open file: $!\n");

##################
# INITIALIZATION #
##################

my $mailobj=Mail::Internet->new(\*INFILE);
close INFILE;

my $mho=$mailobj->head();

my @footags=$mho->tags();
my %tagshandled;
map{$tagshandled{lc ($_)}=$_}@footags;

#quote regex for IP address that /may/ be in square brackets
my $square_ip_qr=qr/^\[?(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\]?$/;
#match []() for removal via s///g (y/// doesn't seem to work on it)
my $square_and_paren_qr=qr/[\[\]\(\)]/;
#captures information within parens
my $parenthesized_qr=qr/\((.*)\)/;

##################
#NOTES           #
##################
#
#Warning: Malformed headers may cause code to stop midway through the headers.
#One significant issue is spam-proofed '<foo at example.com> addresses
#Warning should go on front page that headers should before submission,
#containing well-formed addresses
#(Of course, we should /probably/ try to fix this...)
#
#http://www.dsv.su.se/~jpalme/ietf/ietf-mail-attributes.html
#http://www.cs.tut.fi/~jkorpela/headers.html
#ftp://ftp.ietf.org/rfc/rfc2076.txt
#
#List-*
#http://www.faqs.org/rfcs/rfc2369.html
#
#Content Disposition and then some
#http://www.faqs.org/rfcs/rfc2183.html
#


###################
# TRACE           #
###################

$mho->unfold("Received");
print $mho->as_string; #XXX
my @rcvd=$mho->get("Received");
my %rhpt;


my $lasttime=0;

print "---------\n";
foreach(reverse @rcvd){
	#print "RCVD FROM: $_"; #XXX
	
	my $mhf=Mail::Field->new('Received',$_);
	%rhpt=%{$mhf->parse_tree()};

	my $rcvdpartschecked=0;	

	if (exists $rhpt{'by'}){
		my $bydom=get_rcvd_two_part("by","domain");
		my $bycom0=get_rcvd_two_part("by","comments",1);
		print "<-->At Server\n";
		print "\t$bydom\n";
		print "\tCOMMENTS: $bycom0\n" if $bycom0;
		$rcvdpartschecked++;
	}

	if (exists $rhpt{'date_time'}){
		my $datetime=get_rcvd_two_part("date_time","date_time");
		print "<-->At Time\n";
		print "\t$datetime\n";
		my $currtime=Mail::Field->new('date',$datetime)->time;
		if($lasttime){
			print "\tTime since previous hop: " . duration_exact($currtime-$lasttime) ."\n";
		}
		$lasttime=$currtime;

		$rcvdpartschecked++;
	}

	if (exists $rhpt{'from'}){
		my $rcvdfrom=get_rcvd_two_part("from","from");
		my $rcvdaddr=get_rcvd_two_part("from","address");

		#print "\tRCVD FROM [WHOLE]: $rhpt{'from'}{'whole'}"; #XXX

		#XXX FIXME Add 'with' code, to detect HTTP, local (see SF CVS mail), and MS SMTP (to fix broken headers)

		print "-->From Server\n";

		$rcvdaddr=~s/$square_and_paren_qr//g;
		#print "\t$rcvdfrom / $rcvdaddr\n";
		printf ("%s%s%s", "\t$rcvdfrom", ($rcvdaddr ? " / " :""), "$rcvdaddr\n");

		#
		#COMMENTS / INCL. HELOs
		#
		#	First IP address is $rhpt{'from'}{'address'} !!!!!!!!!!
		#	First ? address is $rhpt{'from'}{'from'} !!!!!!!!!!
		#	Stuff to be interested in, therefore, is DNS and/or HELOs present in comment
		#	Strategy - IGNORE first instance of $rhpt{'from'}{'address'} 
		#
		my $comm0r=get_rcvd_two_part("from","comments",1);
		if ($comm0r) {
			$comm0r=~s/$parenthesized_qr/$1/;
			my @comparts=split(/\s+/, $comm0r);
			my ($currpart,$commip,$commhelo)=("","","");

			foreach $currpart(@comparts){
				if($currpart=~m/^helo(\=(.*)|)$/i){
					$commhelo=$2;
					unless($commhelo){ #if there is NOT a value, get the next element
						$commhelo=shift @comparts; #This is deleting curr. value
						$commhelo=shift @comparts; #It seems this is a localized copy?
					}	#Code should be altered to access next copy or prepend 'helo='
					if($commhelo=~/$square_ip_qr/){
						$commip=$1; #IP addr is captured into $1, less square brackets
						#print "\t\tCOMMENT [HELO_IP]: $commip\n";
						print "\t\tServer identified itself with IP address $commip\n";
					}else{
						$commhelo=~s/$square_and_paren_qr//g;
						#print "\t\tCOMMENT [HELO_HOST]: $commhelo\n";
						print "\t\tServer identified itself with hostname $commhelo\n";
					}
				}else{
					$currpart=~s/$square_and_paren_qr//g;
					print "\t\tComment: $currpart\n" unless (($currpart eq $rcvdfrom) || ($currpart eq $rcvdaddr));
				}
			}#end foreach @comparts
		}#fi comm0r
		$rcvdpartschecked++;
	}
	
	if (exists $rhpt{'for'}){
		print "To Mailbox-->\n";
		my $rcvdfor=get_rcvd_two_part("for","for");
		print "\t$rcvdfor\n";
		$rcvdpartschecked++;
	}

	if ($rcvdpartschecked<=1){
		if (exists $rhpt{'comments'}){
			my $rcvdcomm=$rhpt{'comments'}[0];
			$rcvdcomm=~s/$parenthesized_qr/$1/;
			print "<-->Comment\n";
			print "\t$rcvdcomm\n";
		}else{ #incomplete headers, print whole thing
			if (exists $rhpt{'whole'}){
				my $rcvdwhole=$rhpt{'whole'};
				$rcvdwhole=~s/$parenthesized_qr/$1/;
				print "<-->Entire Received Tag\n";
				print "\tRCVD [WHOLE]: $rcvdwhole\n";
			}
		}
	}
	print "*"x 10 . "\n";
} #end foreach (@rcvd)

delete $tagshandled{lc("Received")};
#*****************#
# /End/ TRACE     #
#*****************#


###################
# MESSAGE         #
###################

print "Humbling displaying information about your message, sir.\n";
print "_-------------_\n";
print "|   Sender    |\n";
print " ------------- \n";
my ($msgfrom,$msgto,$msgcc,$msgsndr,$msgerrto,$msgreplyto,$msgdate,$msgorganization)=get_many_keys("From","To","CC",
	"Sender","Errors-To", "Reply-To", "Date","Organization");
print "Mail from $msgfrom\n" if $msgfrom;
print "\t$msgorganization\n" if $msgorganization;
print "Message sent by $msgsndr\n" if $msgsndr;
print "Please send replies to $msgreplyto\n" if $msgreplyto;
print "Postmaster, please send errors to $msgerrto\n" if $msgerrto;
print "\n";
print "_-------------_\n";
print "|  Addressee  |\n";
print " ------------- \n";
print "Mail to $msgto\n" if $msgto;
print "Carbon copy to $msgcc\n" if $msgcc;
$mho->unfold("Subject");
my ($msgsubj)=get_many_keys("Subject");
print "\n";
print "_-------------_\n";
print "|   Subject   |\n";
print " ------------- \n";
print "$msgsubj\n" if $msgsubj;
print "\n";
print "_-------------_\n";
print "|    When     |\n";
print " ------------- \n";
print "$msgdate\n" if $msgdate;
#XXX FIXME Add ago() code?


###################
# MESSAGE         #
###################
print "\n";
print "_-------------_\n";
print "|   Message   |\n";
print " ------------- \n";
my ($msgid,$msginrepto,$msgreferences)=get_many_keys("Message-ID","In-Reply-To","References");
print "This message has the ID:\n\t$msgid\n" if $msgid;
print "This is a reply to the message with ID:\n\t$msginrepto\n" if $msginrepto; #XXX deal with plurals?
if ($msgreferences){
	print "This message refers to the following message IDs:\n";
	$msgreferences=~s/\s+\n?/\n\t/g;
	print "\t$msgreferences\n";
}

###################
# CLIENT DETAILS  #
###################
print "\n";
print "_-------------_\n";
print "| Client Info |\n";
print " ------------- \n";
my ($msgua,$msgmimevers,$msgxmailer,$msgcontenttype,$msgxacceptlang,$msgcontxferenc)=get_many_keys("User-Agent",
	"MIME-Version","X-Mailer","Content-Type", "X-Accept-Language", "Content-Transfer-Encoding");
print "Sender's mail application: $msgua\n" if $msgua;
print "Sent with: $msgxmailer\n" if $msgxmailer;
print "Sender's mail application accepts e-mail in the following languages: $msgxacceptlang\n" if $msgxacceptlang;
print "Multiparted encoded with MIME version $msgmimevers\n" if $msgmimevers;
print "Message has content type: $msgcontenttype\n" if $msgcontenttype; #XXX FIXME make this nicer
print "Message uses transfer encoding: $msgcontxferenc\n" if $msgcontxferenc; #XXX FIXME make this nicer

###################
# MINUTAE         #
###################
print "\n";
print "_-------------_\n";
print "|   Minutae   |\n";
print " ------------- \n";
my ($msgprecedence)=get_many_keys("Precedence");
print qq|Precedence set to "$msgprecedence"\n| if $msgprecedence;

###################
# LIST INFO       #
###################

my ($larch,$ldig,$lid,$lown,$lpost,$lsoft,$lsub,$lunsub,$lurl)=get_many_keys("List-Archive",
	"List-Digest","List-ID","List-Owner","List-Post","List-Software","List-Subscribe",
	"List-Unsubscribe","List-URL");
my ($lhelp)=get_many_keys("List-Help"); #non standard
print "\n";
print "_------------------_\n";
print "| List information |\n"; # XXX Add IF TEST!
print " ------------------ \n";
print "\t$lid\n" if $lid;
print "The owner of this list is $lown\n" if $lown;
print "Posts can be made to $lpost\n" if $lpost;
print "An archive of this list can be found at $larch\n" if $larch;
print "A digest format of this list can be found at/from $ldig\n" if $ldig;
print "Subscribe to this list at $lsub\n" if $lsub;
print "Unsubscribe from this list at $lunsub\n" if $lunsub;
print "This list uses $lsoft for mail distribution\n" if $lsoft;
print "More information about this list can be found at $lurl\n" if $lurl;
print "Help using this list can be found at $lhelp\n" if $lhelp;

###################
# ALONG THE WAY   #
###################
print "\n";
print "_-------------_\n";
print "|Along the Way|\n";
print " ------------- \n";
my ($msgdelivto,$msgrcvdspf,$msgdomkey,$msgreturnpath)=get_many_keys("Delivered-To",
	"Received-SPF","Domainkey-Signature","Return-Path");
print "\n[Delivery Information]\n";
print "This message was delivered to $msgdelivto\n" if $msgdelivto;
print "The return path for this message is $msgreturnpath\n" if $msgreturnpath;
#XXX FIXME put Return-Path here?
#print "MARID - MTA Authorization Records In DNS"
print "\n[Sender Verification Systems]\n";
if ($msgrcvdspf){
	$msgrcvdspf=~s/\n?//g;
	print "Sender Policy Framework (SPF) test results:\n";
	print "\t$msgrcvdspf\n"; #XXX FIXME!!!!!!!!!!	
}
if ($msgdomkey){
	$msgdomkey=~s/\s+\n?/\n\t/g;
	print "DomainKeys signature details:\n";
	print "\t$msgdomkey\n";
}
	


###################
# FINAL CODE      #
###################

print "\n";
print "_-------------_\n";
print "|  Tags Left  |\n";
print " ------------- \n";
foreach(sort( keys (%tagshandled))){print "$tagshandled{$_}|"}
print "\n";

###################
#METHODS          #
###################

sub get_single_key{
	my $keyname=shift;
	my $tmpkey;
	$tmpkey=$mho->get($keyname);
	delete $tagshandled{lc($keyname)};
	if ($tmpkey){
		chomp $tmpkey;
		return $tmpkey;
	}else{
		return "";
	}
}

sub get_many_keys{
	my @keynames=@_;
	my @output;
	map{push @output, get_single_key($_)}@keynames;
	return @output;

}

sub get_rcvd_two_part{
	my ($grmaj,$grmin,$getcomm)=@_;
	my $tmpkey="";
	unless($getcomm){ #don't get comment
		$tmpkey=$rhpt{$grmaj}{$grmin};
	}else{#get comment
		$tmpkey=$rhpt{$grmaj}{$grmin}[0];
	}
	if ($tmpkey){
		chomp $tmpkey;
		return $tmpkey;
	}else{
		return "";
	}
}

#=================#
# DEAD CODE       #
#=================#
#
#migrated to comments.txt