#!/usr/bin/perl
# Forward CA OES EDIS warnings affecting Santa Clara County to SVWUX EDIS list.
# Since OES e-mails are so incomplete, they are mainly used as a trigger to
# retrieve the Common Alerting Protocol (CAP) XML record from OES's web site.
# Then more filtering can be done to eliminate messages inappropriately marked
# with a statewide distribution.  Keeping it on-topic will help make it more
# useful to local users.
#
# written by Ian Kluft
# for the Silicon Valley Wireless Users and eXperimenters (SVWUX)

use strict;
use Carp;
use POSIX qw( atan asin cos sin sqrt );
use Getopt::Long;
use Text::Wrapper;
use MIME::Parser;
use MIME::Lite;
use XML::Parser;
use XML::Atom::Client;
use XML::Atom::Feed;
use XML::Atom::Entry;
use YAML::Syck;
use LWP::UserAgent;
use Data::Dumper;

# define exceptions/errors
use Exception::Class (
	'ComplainNowException',
	'SilentlyExitException',

	'ChdirTmpException' => {
		'isa' => 'ComplainNowException',
		'description' => 'failed to change to temp directory',
		'trace' => 0,
	},

	'UsageException' => {
		'isa' => 'ComplainNowException',
		'description' => 'usage: edis-mail --config=path',
		'trace' => 0,
	},

	'ConfigNotFoundException' => {
		'isa' => 'ComplainNowException',
		'description' => 'failed to parse/process configuration file',
		'trace' => 0,
	},

	'ConfigParseException' => {
		'isa' => 'ComplainNowException',
		'description' => 'failed to parse/process configuration file',
		'trace' => 0,
	},

	'MimeParseException' => {
		'isa' => 'ComplainNowException',
		'description' => 'MIME message parsing failed',
		'trace' => 0,
	},

	'MailerPipeOpenException' => {
		'isa' => 'ComplainNowException',
		'description' => 'failed to open pipe to mailer',
		'trace' => 0,
	},

	'MailerPipePrintException' => {
		'isa' => 'ComplainNowException',
		'description' => 'failed to output to mailer pipe',
		'trace' => 0,
	},

	'MailerPipeCloseException' => {
		'isa' => 'ComplainNowException',
		'description' => 'failed to close pipe to mailer',
		'trace' => 0,
	},

	'TestMessageException' => {
		'isa' => 'SilentlyExitException',
		'description' => 'received a test message - safe to ignore',
		'trace' => 0,
	},

	'CapXmlNotFoundException' => {
		'isa' => 'ComplainNowException',
		'description' => 'CAP XML not found - processing cannot continue',
		'trace' => 1,
	},

);

#
# globals
#

my $VERSION = "0.5";
my $debug = (( exists $ENV{DEBUG} ) and $ENV{DEBUG});
my $tmpdir = (( exists $ENV{TMPDIR} ) and $ENV{TMPDIR})
        ? $ENV{TMPDIR} : "/var/tmp";
my $exim_cmd = "/usr/sbin/exim";
my $mode = 1;
my @warning_text;
my $oes_sent_str;
my $oes_area_str;
my $edis_atom_uri = "http://edis.oes.ca.gov/index.atom";
my $pi = 4.0 * atan(1);

#
# functions
#

# print debugging statements
sub debug
{
        $debug and print STDERR "debug: ".join("",@_)."\n";
}

# get command line parameters
sub get_cmdline
{
	my %cmdline;

	# process command line into %cmdline hash
	GetOptions ( \%cmdline, "debug", "tmpdir:s", "config=s" )
		or UsageException->throw();

	# check required parameters
	if ( !exists $cmdline{config}) {
		UsageException->throw();
	}

	# check parameters with special meaning at start-up
	if ( exists $cmdline{debug}) {
		$debug = $cmdline{debug};
	}
	if (( exists $cmdline{tmpdir}) and ( length( $cmdline{tmpdir}) > 0 )) {
		$tmpdir = $cmdline{tmpdir};
	}

	return \%cmdline;
}

# read the YAML configuration file
sub get_config
{
	my $config_path = shift;

	# make sure it exists
	if ( ! -e $config_path ) {
		ConfigNotFoundException->throw();
	}

	# read and parse the configuration
	my $data = YAML::Syck::LoadFile( $config_path );
	if ( !defined $data ) {
		ConfigParseException->throw();
	}

	# return the configuration
	return $data;
}

# convert degrees to radians for trig functions
sub deg2rad
{
        $_[0] * $pi / 180.0;
}

# convert radians to degrees for trig functions
sub rad2deg
{
        $_[0] * 180 / $pi;
}

# compute great circle distance (in statute miles)
sub gc_dist
{
        my ( $lat1, $lon1, $lat2, $lon2 ) = @_;
        debug "dist ( $lat1, $lon1, $lat2, $lon2 )";

        # note: this great-circle forula should not be used near the poles
        # see http://users.netonecom.net/~rburtch/geodesy/datm_faq.html#2.1
        
        # Earth radius is estimated for each leg (Why? Because we can!)
        my $earth_radius = 6378.0 - 21.0 * sin(deg2rad(($lat1+$lat2)/2.0));
        
        # differences in lattitude and longitude
        my $dlat = abs($lat1-$lat2);
        my $dlon = abs($lon1-$lon2);

        # compute great-circle distance
        my $a = sin(deg2rad($dlat/2.0)) * sin(deg2rad($dlat/2.0))
                + cos(deg2rad($lat1))
                * cos(deg2rad($lat2))
                * sin(deg2rad($dlon/2.0)) * sin(deg2rad($dlon/2.0));
        my $c = 2.0 * asin(sqrt($a));

        # convert distance in radians on Earth-surface arc to meters
        debug "distance (mi) = ".( $earth_radius * $c * 0.62137119 )
                .", c = $c, a = $a, dlat = $dlat, dlon = $dlon";
        return $earth_radius * $c * 0.62137119;

}

# test earthquake location and magnitude for relevance to local area 
# returns 1 = distance/magnitude violation, 0 = no violation found
sub quake_dist_violation
{
	my $config = shift;	# config hash
	my $rn = shift;		# region name
	my $q_lat = shift;	# quake latitude
	my $q_lon = shift;	# quake longitude
	my $q_mag = shift;	# quake magnitude

	# set ref to current region
	my $region = $config->{region}{$rn};

	# code ref to read quake parameters from regional or global config
	my $eq_par = sub {
		my $name = shift; 
		if ( exists $region->{eq}{$name}) {
			return $region->{eq}{$name};
		} elsif ( exists $config->{eq}{$name}) {
			return $config->{eq}{$name};
		} else {
			return undef;
		}
	};

	# reject quakes which are roo small
	( $q_mag < &$eq_par( "lo_mag" )) and return 1;

	# compute land-based thresholds using magnitude
	my $eq_land_dist;
	if ( $q_mag >= &$eq_par( "hi_mag" )) {
		$eq_land_dist = &$eq_par( "hi_radius" );
	} else {
		my $frac = ($q_mag - &$eq_par( "lo_mag" ))
			/ ( &$eq_par( "hi_mag" ) - &$eq_par( "lo_mag" ));
		$eq_land_dist = ( $frac ** 3 )
			* ( &$eq_par( "hi_radius" ) - &$eq_par( "lo_radius" ))
			+ &$eq_par( "lo_radius" );
	}
	if ( gc_dist( $q_lat, $q_lon, @{&$eq_par( "coord" )})
		<= &$eq_par( "land_dist" ))
	{
		return 0; # not a violation
	}

	# compute sea-based thresholds using magnitude
	( $q_mag < &$eq_par( "sea_mag" )) and return 1; # too low for tsunami
	if ( &$eq_par( "sea_enable" )) {
		if ( gc_dist( $q_lat, $q_lon, @{&$eq_par( "sea_coord" )})
			<= &$eq_par( "sea_radius" ))
		{
			return 0; # not a violation
		}
	}

	# if not determined to be in range above, it's a violation
	return 1;
}

# check if statewide alert appears not to be of local interest
# 1) content has phone numbers and none are local
# 2) content has names of counties and none are local
# returns 1 = distance violation, 0 = no violation found
sub context_violation
{
	my $config = shift;	# config hash
	my $rn = shift;		# region name
	my @content = shift;	# warning message content
	my $content = lc(join ( " ", @content ));

	# set ref to current region
	my $region = $config->{region}{$rn};

	# check phone numbers
	my %ac_found;
	my $phone_found = 0; # phone numbers found
	while ( $content =~ /\(([0-9]{3})\)\s*[0-9]{3}-[0-9]{4}/g ) {
		$ac_found{$1} = 1;
		$phone_found = 1;
	}
	while ( $content =~ /([0-9]{3})-[0-9]{3}-[0-9]{4}/g ) {
		$ac_found{$1} = 1;
		$phone_found = 1;
	}
	while ( $content =~ /([0-9]{3}) [0-9]{3} [0-9]{4}/g ) {
		$ac_found{$1} = 1;
		$phone_found = 1;
	}
	foreach my $ac ( sort keys %ac_found ) {
		if (( defined $region->{areacodes}{$ac})
			and $region->{areacodes}{$ac})
		{
			# stop: found a phone number in the local region
			debug "phone OK";
			return 0; # not a violation
		}
	}

	# check counties
	my $county_found = 0;
	foreach my $county ( @{$config->{state}{counties}} ) {
		if ( $content =~ /$county county/i
			or $content =~ /$county sheriff/i )
		{
			$county_found = 1;
			if (( defined $region->{counties}{$county})
				and $region->{counties}{$county})
			{
				# stop: found a county in the local region
				debug "county OK";
				return 0; # not a violation
			}
		}
	}

	# check cities
	my $city_found = 0;
	foreach my $city ( @{$config->{state}{cities}} ) {
		if ( $content =~ /city of $city/i
			or $content =~ /$city city/i
			or $content =~ /$city,{0,1} ca[^\W]/i
			or $content =~ /$city,{0,1} california/i
			or $content =~ /$city police/i )
		{
			$city_found = 1;
			if (( defined $region->{cities}{$city})
				and $region->{cities}{$city})
			{
				# stop: found a county in the local region
				debug "city OK";
				return 0; # not a violation
			}
		}
	}

	# check for violations 
	if ( $phone_found or $county_found or $city_found ) {
		# if we got here with anything found, must be a violation
		# otherwise we'd have returned 0 earlier
		debug "distance violation phone:$phone_found "
			."county:$county_found city:$city_found";
		return 1; # violation found
	}

	# otherwise no violation
	debug "no distance indication, assume OK";
	return 0; # not a violation
}

# build a CAP tree by recursion into an XML parse tree
sub build_cap_tree
{
	my $cap = shift;
	my $xml = shift;
	my $name = shift;

	debug "build_cap_tree("
		.(ref $cap).", ".(ref $xml).", ".(ref $name).")";

	#
	# scan a level of the XML parse tree
	#

	# skip initial hash ref for attributes - CAP doesn't use them
	my $i = ( ref $xml->[0] eq "HASH" ) ? 1 : 0;

	# loop through array representing contents of an XML tag
	for ( ; $i < scalar @$xml; $i += 2 ) {
		debug "$i: $xml->[$i]";
		if ( $xml->[$i] eq "alert" ) {
			# alert: the top-level structure
			# just descend into it - the $cap tree is for it
			debug "alert";
			build_cap_tree( $cap, $xml->[$i+1]);

		} elsif ( $xml->[$i] eq "0" ) {
			# process a text string

			# skip entries which are all whitespace
			$xml->[$i+1] =~ s/^\s*//smg; # leading whitespace
			$xml->[$i+1] =~ s/\s*$//smg; # trailing whitespace
			if ( length($xml->[$i+1]) == 0 ) {
				next;
			}

			# save text
			if ( defined $name ) {
				debug $name.": ".$xml->[$i+1];
				$cap->{$name} = $xml->[$i+1];
			} else {
				debug "name undefined - cannot save string $xml->[$i+1] (element ".($i+1)." of ".join("/",@$xml).")";
			}

		} elsif ( $xml->[$i] eq "info" ) {
			# info: create list of subtrees
			debug $xml->[$i];
			if ( !exists $cap->{$xml->[$i]}) {
				$cap->{$xml->[$i]} = [];
			}
			my $subtree = {};
			build_cap_tree( $subtree, $xml->[$i+1] );
			push @{$cap->{$xml->[$i]}}, $subtree;

		} elsif (( $xml->[$i] eq "resource" )
			or ( $xml->[$i] eq "area" ))
		{
			# resource and area: create subtree
			debug $xml->[$i];
			my $subtree = {};
			build_cap_tree( $subtree, $xml->[$i+1] );
			$cap->{$xml->[$i]} = $subtree;

		} elsif ( $xml->[$i] eq "eventCode"
			or $xml->[$i] eq "parameter"
			or $xml->[$i] eq "geoCode" )
		{
			# handle data types with name/value pairs
			debug $xml->[$i];
			if ( !exists $cap->{$xml->[$i]}) {
				$cap->{$xml->[$i]} = {};
			}

			# scan parameter tree to get valueName and value
			my $param = {};
			build_cap_tree( $param, $xml->[$i+1] );
			if (( exists $param->{valueName})
				and ( exists $param->{value}))
			{
				my $vname = $param->{valueName};
				my $value = $param->{value};
				debug $xml->[$i].": $vname = $value";
				$cap->{$xml->[$i]}{$vname} = $value;
			} else {
				debug "value/valueName not found in $name";
			}

		} elsif ( ref $xml->[$i] ) {
			debug "error - want tag name, got ".$xml->[$i];

		} else {
			# other tags are expected to contain just a string
			debug $xml->[$i];
			build_cap_tree( $cap, $xml->[$i+1], $xml->[$i]);
		}
	}
}

# fetch a Common Alerting Protocol record from a URL
sub fetch_cap
{
	my $url = shift;

	my $ua = LWP::UserAgent->new;
	$ua->agent("svwux-edis-mail/".$VERSION);
	my $req = HTTP::Request->new( GET => $url );
	my $res = $ua->request($req);
	if ($res->is_success) {
		# transcribe data to cap record and return it
		my $content = $res->content;
		my $p = XML::Parser->new(Style => 'Tree');
		my $xml = $p->parse( $content );
		my $cap = {};
		build_cap_tree ( $cap, $xml );
		return ( $cap, $content );
	} else {
		return undef;
	}
}

# convert CAP info block to text report
sub info2text
{
	my $info = shift;
	my $text;
	my $wrapper = Text::Wrapper->new( columns => 76 );

	$text = $wrapper->wrap(
		(( exists $info->{headline}) ? $info->{headline}."\n\n" : "" )
		.(( exists $info->{description}) ? $info->{description}."\n\n" : "" )
		.(( exists $info->{instruction}) ? $info->{instruction}."\n\n" : "" )
		.(( exists $info->{area}{areaDesc}) ? "Area: ".$info->{area}{areaDesc}."\n\n" : "" )
		.(( exists $info->{web}) ? "Web: ".$info->{web}."\n" : "" )
		.(( exists $info->{category}) ? "Category: ".$info->{category}."\n" : "" )
		.(( exists $info->{event}) ? "Event: ".$info->{event}."\n" : "" )
		.(( exists $info->{senderName}) ? "Sender: ".$info->{senderName}."\n" : "" )
		.(( exists $info->{expires}) ? "Expires: ".$info->{expires}."\n" : "" )
		.(( exists $info->{urgency}) ? "Urgency: ".$info->{urgency}."\n" : "" )
		.(( exists $info->{severity}) ? "Severity: ".$info->{severity}."\n" : "" )
		.(( exists $info->{certainty}) ? "Certainty: ".$info->{certainty}."\n" : "" )
		);
	return $text;
}

# generate alert for mail list
sub generate_alert
{
	my $config = shift;	# config hash
	my $rn = shift;		# region name
	my $cap = shift;	# parsed Common Alerting Protocol (CAP) record
	my $notes = shift;	# notes collected from mail and CAP messages

	#
	# generate the message and feed it to the mailer
	#

	# set ref to current region
	my $region = $config->{region}{$rn};

	# generate report text
	my @text_report;
	foreach my $info ( @{$cap->{info}}) {
		push @text_report, info2text( $info );
	}
	push @text_report, "See ".$notes->{xml_url}."\n"
		."Sent: ".$cap->{sent}."\n"
		."Status: ".$cap->{status}."\n"
		."Message Type: ".$cap->{msgType}."\n";
	debug "text array has ".(scalar @text_report)." entries";

	# instantiate the MIME message object with the message headers
	my $to_addr = $debug ? $config->{debug_addr} : $region->{to_addr};
	my $msg = MIME::Lite->new (
		Subject	=>	 $notes->{subject},
		To	=>	 $to_addr,
		From	=>	 $to_addr,
		Date	=>	 $notes->{date},
		Type	=>	'text/plain; charset=US-ASCII',
		Encoding =>	'7bit',
		Data	=>	\@text_report
	);

	# add CAP XML attachment
	$notes->{xml_raw} =~ s*xml-stylesheet href="capstateoes_simple.xsl"*xml-stylesheet href="http://edis.oes.ca.gov/capstateoes_simple.xsl"*;
	debug "XML attachment is ".(length $notes->{xml_raw})." characters";
	$msg->attach(   Type => 'text/xhtml; charset=US-ASCII',
			Filename => "edis-cap-".$cap->{identifier}.".xhtml",
			Data => $notes->{xml_raw},
			Encoding => '7bit',
			Disposition => 'attachment ');

	# send mail
	if ( ! open EXIM_PIPE, "|$exim_cmd $to_addr" ) {
		MailerPipeOpenException->throw( $! );
	}
	$msg->print( \*EXIM_PIPE ) or MailerPipePrintException->throw( $! );
	if ( !close EXIM_PIPE ) {
		MailerPipeCloseException->throw( $! );
	}
	debug "message sent";
}

#
# receive e-mail message from STDIN
#
sub main
{
	# read command-line
	my $cmdline = &get_cmdline;

	# read configuration
	my $config = &get_config( $cmdline->{config});

	# chdir to temp directory
	chdir ( $tmpdir ) or ChdirTmpException->throw( $! );

	# read mail from stdin
	my $parser = new MIME::Parser;
	my $entity = $parser->parse(\*STDIN) or MimeParseException->throw();
	my $headers = $entity->head;
	my $body = $entity->bodyhandle;

	# collect info from headers
	my $subject = $headers->get('Subject');
	$subject =~ s/\s*$//; # strip trailing spaces
	my $date = $headers->get('Date');
	$date =~ s/\s*$//; # strip trailing spaces

	# parse the message
	my $IO = $body->open("r");
	my $line;
	while ( defined($line = $IO->getline)) {
		chomp;
		$line =~ s/\s*$//; # strip trailing spaces
		debug "got: $line";

		if ( $mode == 1 ) {
			if ( $line =~ /This is a test message for/ ) {
				# do not forward test messages
				TestMessageException->throw();
			}
			if ( $line =~ /Dear Subscriber/ ) {
				$mode = 2;
				next;
			}
			if ( $line =~ /^\s*$/ ) {
				next;
			} else {
				$mode = 2;
				# no next - continue to process this line in mode 2
			}
		}

		if ( $mode == 2 ) {
			if ( $line =~ /Please read the instructions below/ ) {
				$mode = 3;
				next; # do not include this line
			}
			if ( $line =~ /^Sent:\s*(.*)/ ) {
				$oes_sent_str = $1;
			}
			if ( $line =~ /^Area:\s*(.*)/ ) {
				$oes_area_str = lc($1);
			}
			if ( $line =~ /^\s*$/ and scalar @warning_text == 0 ) {
				# skip blank lines before beginning of text
				next;
			}
			push @warning_text, $line;
		}

		# ignore mode 3 - processing done at that point
	}

	# clean up resources
	$IO->close;
	$body->purge;

	# store notes from processing mail and CAP messages
	my $notes = {
		"subject" => $subject,
		"date" => $date,
	};

	#
	# find matching entry on EDIS' Atom feed
	# since the e-mails are incomplete
	# They don't include the URL of the full Common Alerting Protocol (CAP) record.
	# We have to scan current events in the Atom feed for one posted at the same
	# time.  (There's room for improvement here!)  Then we grab the CAP record
	# from the URL listed there.
	#

	my $atom = XML::Atom::Client->new;
	my $cap_ns =  XML::Atom::Namespace->new(cap => 'urn:oasis:names:tc:emergency:cap:1.1' );
	my $feed = $atom->getFeed($edis_atom_uri);
	my @entries = $feed->entries;
	my $cap;
	foreach my $entry ( @entries ) {
		if ( $oes_sent_str eq $entry->updated ) {
			# get the URL and fetch the CAP record
			my @links = $entry->link;
			foreach my $link ( @links ) {
				if ( $link->rel eq "alternate" ) {
					$notes->{xml_url} = $link->href;
					( $cap, $notes->{xml_raw}) = fetch_cap ( $notes->{xml_url} );
					last;
				}
			}
		}
	}
	if ( ! defined $cap ) {
		CapXmlNotFoundException->throw();
	}

	# per-region loop
	my $rn;
	region_loop: foreach $rn ( sort keys %{$config->{region}}) {

		# abort if statewide alert appears not to be of local interest
		if (( $oes_area_str eq "statewide" )
			and &context_violation( $config, $rn, @warning_text ))
		{
			next region_loop;
		}

		# check earthquake events against distance/magnitude forwarding thresholds
		my $total_valid_entries = 0;
		my $i;
		for ( $i = 0; $i <= scalar @{$cap->{info}}; $i++ ) {
			if (( exists $cap->{info}[$i]{event})
				and ($cap->{info}[$i]{event} eq "Earthquake" ))
			{
				my $mag = $cap->{info}[$i]{parameter}{magnitude};
				my $circle = $cap->{info}[$i]{area}{circle};
				if (( ! defined $mag ) or ( ! defined $circle )) {
					debug "skip earthquake event: no mag/circle (error)";
					next;
				}
				my ( $lat, $lon ) = ( $circle =~ /([0-9.]+),([0-9.]+)\w/ );
				if ( ! quake_dist_violation( $config, $rn, $lat, $lon, $mag )) {
					debug "valid earthquake event (OK)";
					$total_valid_entries++;
				} else {
					debug "skip earthquake event for dist/mag (OK)";
				}
			} else {
				# not an earthquake, assume valid for this test
				debug "valid event ".($i+1)." of "
					.(scalar @{$cap->{info}})." (OK)";
				$total_valid_entries++;
				last;
			}
		}
		if ( $total_valid_entries == 0 ) {
			next region_loop;
		}

		# generate alert for mail list
		&generate_alert( $config, $rn, $cap, $notes );
	}
}

# try processing and catch exceptions
eval { &main; };
my $e;
if ( $e = Exception::Class->caught( 'ComplainNowException' )) {
	my %fields = $e->Fields;
	warn "$0: ".$e->error, "\n",
		$e->description, "\n",
		( $fields{trace} ? ( $e->trace->as_string, "\n" ) : ());
	exit 1;
} elsif ( $e = Exception::Class->caught( 'SilentlyEscapeException' )) {
	if ( $debug ) {
		my %fields = $e->Fields;
		warn "$0: (debug warning) ".$e->error, "\n",
			$e->description, "\n",
			( $fields{trace} ? ( $e->trace->as_string, "\n" ) : ());
	}
	exit 0;
} else {
	$e = Exception::Class->caught();
	if ( ! $e ) {
		exit 0;
	} elsif ( ref $e ) {
		$e->rethrow;
	} else {
		die $e;
	}
}

# should not get here
confess "fell through - should not get here\n";