#!/usr/bin/perl

use CGI;
use IO::Socket::INET;
use XML::Parser;
use XML::LibXML;
use Net::Subnets;
use JSON;
use WWW::Mechanize;
use strict;

### Constants
my $id_rand_len = 32;
my $ref_param = "ref";
my $dbfile = "held-cache.conf";
my $logfile = "held-log.txt";
my $swarmfile = "held-swarm.txt";
my @ietf_subnets = (
	"130.129.16.0/20",
	"130.129.32.0/20",
	"130.129.48.0/20",
	"130.129.64.0/20",
	"130.129.80.0/20",
	"130.129.96.0/20",
	);
my $gears_uri = "http://www.google.com/loc/json";


### Derived constants
my $subnets = Net::Subnets->new;
$subnets->subnets( \@ietf_subnets );

###
### Subroutine: Store a value in the database
###  Input: key, value (value MUST NOT contain "\t")
###  Output: nothing
###
sub db_put($$)
{
	my($key,$value) = @_;
	print DBFILE "$key\t$value\n";
}

###
### Subroutine: Get a value from the database 
###  Input: key
###  Output: value 
###
sub db_get($)
{
	my $key = shift;
	my @db = `cat $dbfile`;
	my @goodlines = grep /^$key\t/, @db;
	if (!@goodlines) { return undef; }
	else {
		my $val = $goodlines[0];
		$val =~ s/^$key\t//;
		chomp($val);
		return $val;
	}
}

###
### Subroutine: Get the key for a value from the database 
###  Input: value
###  Output: key 
###
sub db_rget($)
{
	my $key = shift;
	my @db = `cat $dbfile`;
	my @goodlines = grep /\t$key$/, @db;
	if (!@goodlines) { return undef; }
	else {
		my $val = $goodlines[0];
		$val =~ s/\t$key$//;
		chomp($val);
		return $val;
	}
}


###
### Subroutine: Generate a string of random characters
###  Input: Length of string
###  Output: String
### Courtesy of http://guymal.com
### 
sub random_id ()
{
	my $length_of_randomstring=$id_rand_len; 

	my @chars=('a'..'z','A'..'Z','0'..'9');
	my $random_string;
	foreach (1..$length_of_randomstring) 
	{
		# rand @chars will generate a random 
		# number between 0 and scalar @chars
		$random_string.=$chars[rand @chars];
	}
	return $random_string;
}
### END sub random_string



### 
### Subroutine: Get location (from one of multiple sources)
###  Input: IP address (in text form)
###  Output: Hash of location information
###
sub get_location($%) {
	my $ip = $_[0];
	my %meas = %{$_[1]};

	return gears_get_location($ip, \%meas);
}

### 
### Subroutine: Get location from Google Gears
###  Input: IP address (in text form), wifi measurement hash
###  Output: Hash of location information
###
sub gears_get_location($%) {
	my $ip = $_[0];
	my %meas = %{$_[1]};
	my %out = ();

	# Construct the query
	my $gearsRequest = '{ "version": "1.1.0", "wifi_towers": [';
	my @macs = keys %meas;
	for (my $i=0; $i<= $#macs; ++$i) {
		$gearsRequest .= '{ "mac_address": "'. $macs[$i] . '", ';
		$gearsRequest .= '"signal_strength": '. $meas{$macs[$i]} .'} ';
		if ($i < $#macs) { $gearsRequest .= ", "; }
	}
	$gearsRequest .= '] }';

	# Send the query
	my $gears_uri = "http://www.google.com/loc/json";
	my $browser = LWP::UserAgent->new();
	my $response = $browser->post($gears_uri, Content=>$gearsRequest);
	my $gearsResponse = "";
	if ($response->is_success) {
		$gearsResponse = $response->content;
	} else {
		return \%out;
	}

	# Decode the response
	my $decodedResponse = from_json( $gearsResponse );
	if (!$decodedResponse || !($decodedResponse->{location})) {
		return \%out;
	}

	# Construct the object to return
	$out{"Latitude"} = $decodedResponse->{location}->{latitude};	
	$out{"Longitude"} = $decodedResponse->{location}->{longitude};	
	$out{"Accuracy"} = $decodedResponse->{location}->{accuracy};	

	return \%out;
}


###
### Subroutine: Parse the XML locationRequest
###  Input: String containing XML
###  Output: Hash containing relevant parameters
###
sub parse_request($)
{
	my $in = shift; 
	my %out = ();
	my $error_code;
	my $error_message;

	my $checker = XML::Parser->new( ErrorContext => 2 );
	my $parser = new XML::LibXML;
	my $doc;	

	# Check that it the XML well-formed using XML::Parser...
	eval { $checker->parse( $in ); };
	if ($@) {
		$error_code = "xmlError";
		$error_message = "Mal-formed XML locationRequest";
		goto error;
	}
	# ... then get the DOM using libxml (which dies on malformed)
	eval { $doc = $parser->parse_string($in); };
	
	# Check that we actually have a locationRequest object
	my $req = $doc->documentElement();
	if ($req->localname() ne "locationRequest") {
		$error_code = "unsupportedMessage";
		$error_message = "Only requests of type locationRequest are supported"; 
		goto error;
	}

	# Pull the data
	$out{"responseTime"} = $req->getAttribute("responseTime");
	
	my $locationTypeElement = ${$req->getChildrenByTagName("locationType")}[0];
	if ($locationTypeElement) {
		$out{"exact"} = $locationTypeElement->getAttribute("exact");
		my $locationTypeString = $locationTypeElement->textContent;
		my @locationTypes = split(/\s+/, $locationTypeString);
		@locationTypes = grep /any|civic|geodetic|locationURI/, @locationTypes;
		$out{"locationType"} = join(" ", @locationTypes);
	}

	my $measElement = ${$req->getChildrenByTagName("measurements")}[0];
	my %meas = ();
	if ($measElement) {
		my $wifiElement = ${$measElement->getChildrenByTagName("wifi")}[0];
		if ($wifiElement) {
			my @aps = ();
			push @aps, @{$wifiElement->getChildrenByTagName("servingWap")};
			push @aps, @{$wifiElement->getChildrenByTagName("neighbourWap")};
	
			foreach my $apElement (@aps) {
				my $bssidElement = ${$apElement->getChildrenByTagName("bssid")}[0];
				my $rssiElement = ${$apElement->getChildrenByTagName("rssi")}[0];
				if ($bssidElement && $rssiElement) {
					$meas{$bssidElement->textContent()} = $rssiElement->textContent();
				}
			}
		}
	}
	$out{"wifiMeas"} = \%meas;
	
	return \%out;

	error:
	$out{"error_code"} = $error_code;
	$out{"error_message"} = $error_message;
	return \%out;
}
### END sub parse_request

###
### Subroutine: Log a HELD transaction
###  Input: 1) Method of the HTTP request
###         2) Body of the HTTP request 
###         3) Value of the locationResponse returned
###         4) Value of the errorResponse returned
###  Output: None
###
sub log_transaction($$$$$) {
#	my($method, $ruri, $body, $locationResponse, $errorResponse) = @_;
#	print LOGFILE "<held-transaction>\n";
#	print LOGFILE "<request method='$method' uri='$ruri'>\n";
#	print LOGFILE "$body\n";
#	print LOGFILE "</request>\n";
#	print LOGFILE "<locationResponse>\n";
#	print LOGFILE "$locationResponse\n";
#	print LOGFILE "</locationResponse>\n";
#	print LOGFILE "<errorResponse>\n";
#	print LOGFILE "$errorResponse\n";
#	print LOGFILE "</errorResponse>\n";
#	print LOGFILE "</held-transaction>\n\n\n";
#	return;
}
### END sub log_transaction

BEGIN: 


open DBFILE, ">>$dbfile" or die "Unable to open URI cache: $!\n";
select((select(DBFILE), $|=1)[0]);
open LOGFILE, ">>$logfile" or die "Unable to open transaction log: $!\n";
select((select(LOGFILE), $|=1)[0]);

###
### BEGIN Server Logic
###

	my $error_code = "";
	my $error_message = "";

	###
	### Step 1: Read the request
	###

	# Pull out relevant things from the environment
	my $method = $ENV{'REQUEST_METHOD'};
	my $request_uri = $ENV{'REQUEST_URI'};
	my $my_hostname = $ENV{'SERVER_NAME'};
	my $my_uri = $ENV{'SCRIPT_URI'};
	my $client_ip = $ENV{'REMOTE_ADDR'};

	# If this is a reference it should be in a query string variable
	my $loc_reference = $ENV{"QUERY_STRING"};

	# Check that the request method is either GET or POST
	if (($method != "GET")&&($method != "POST")) {
		$error_code = "requestError";
		$error_message = "HTTP method MUST be GET or POST";
		goto error;
	}

	# If it's a POST, we'll need to read the body
	my $body = "";
	if ($method eq "POST") {
		while (<>) { $body .= $_; }
	} 

	my $ip = "";
	# Decide which IP to use
	if (!$loc_reference) {
		# If there's no path component, it's the LCP; use the src IP
		$ip = $client_ip;
	} else {
		# Else, validate the path component and try to retrieve the cached IP
		my $reference_valid = ($loc_reference =~ /^[a-zA-Z0-9]{$id_rand_len}$/);
		# If the path looks good, try to get a cached IP
		if ($reference_valid) {
			$ip = db_get($loc_reference) or '';

			if (!$ip) {
				$error_code = "locationUnknown";
				$error_message = "No target IP found for reference";
				goto error;
			}
		} else {
			$error_code = "requestError";
			$error_message = "Mal-formed reference";
			goto error;
		}	
	}

	###
	### Step 1a: Parse the request
	###
	my %req = ();
	if ($body ne "") { %req = %{parse_request($body)}; }
	if ($req{"error_code"}) {
		$error_code = $req{"error_code"};
		$error_message = $req{"error_message"};
		goto error;
	}
	# NB: We ignore the responseTime attribute.
	my %meas;
	if ($req{"wifiMeas"}) {
		%meas = %{$req{"wifiMeas"}};
	} else {
		undef %meas;
	}

	###
	### Step 2: Use the IP address to get location from Akamai
	###
	my %loc_info = %{get_location($ip,\%meas)};

	###
	### Step 3: Construct the PIDF-LO(s)
	###
	# Determine which formats to return
	# First, see which we can determine from the given data
	my $got_geo = (($loc_info{"Latitude"})&&($loc_info{"Longitude"}));
	my $got_civic = (($loc_info{"Country Code"})||($loc_info{"Region Code"})||($loc_info{"County"})||($loc_info{"City"})||($loc_info{"country"}));
	# Willing to provide a URI if we've got either geo or civic, fail otherwise
	my $got_uri = ($got_geo || $got_civic);
	if (!$got_geo && !$got_civic) {
		$error_code = "locationUnknown";
		$error_message = "Unable to determine location for target IP address";
	}
	my $geo_lo = "";
	my $civic_lo = "";
	my $uri_lo = "";

	# Next, see which are allowed by the request (start false, flip to true)
	my $geo_allowed = undef;
	my $civic_allowed = undef;
	my $uri_allowed = undef;
	if (!$req{"locationType"} || !$req{"exact"} || $req{"exact"} ne "true") {
		$geo_allowed = !$geo_allowed;
		$civic_allowed = !$civic_allowed;		
		$uri_allowed = !$uri_allowed;
	}
	elsif ($req{"locationType"} =~ /civic|any/) { $civic_allowed = !$civic_allowed; }
	elsif ($req{"locationType"} =~ /geodetic|any/) { $geo_allowed = !$geo_allowed; }
	elsif ($req{"locationType"} =~ /locationURI|any/) { $uri_allowed = !$uri_allowed; }

	# Match the two criteria up; if nothing's left, fail with cannotProvideLiType
	my $geo = ($got_geo && $geo_allowed);
	my $civic = ($got_civic && $civic_allowed);
	my $uri = ($got_uri && $uri_allowed);
	if (!$geo && !$civic && !$uri) {
		$error_code = "cannotProvideLiType";
		$error_message = "Available LI types: ";
		if ($got_geo) { $error_message .= "geodetic "; };
		if ($got_civic) { $error_message .= "civic "; };
		goto error;
	}

	# Make the wrapper for the presence object if we're going to return one
	my $lo_header = "";
	my $lo_footer = "";
	if ($geo || $civic) {
		$lo_header .= qq|<presence xmlns="urn:ietf:params:xml:ns:pidf" \n|;
		$lo_header .= qq|          xmlns:gp="urn:ietf:params:xml:ns:pidf:geopriv10" \n|;
		$lo_header .= qq|          xmlns:cl="urn:ietf:params:xml:ns:pidf:geopriv10:civicAddr" \n|;
		$lo_header .= qq|          xmlns:gml="http://www.opengis.net/gml" \n|;
		$lo_header .= qq|          xmlns:gs="http://www.opengis.net/pidflo/1.0" \n|;
		$lo_header .= qq|          entity="pres:$ip\@$my_hostname"> \n|;
		$lo_footer .= qq|</presence> \n|;
	}

	# Create a geodetic tuple 
	if ($geo)
	{
	
		# Generate a tuple ID
		my $tuple_id = random_id();
		# Compute the timestamp
		my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time);
		my $timestamp = sprintf "%4d-%02d-%02dT%02d:%02d:%02d+00:00", $year+1900, $mon+1, $mday, $hour, $min, $sec;
		# Grab the lat/long
		my $lat = $loc_info{"Latitude"};
		my $lon = $loc_info{"Longitude"};
		my $acc = $loc_info{"Accuracy"};
		
		$geo_lo .= qq|  <tuple id="$tuple_id"> \n|; 
		$geo_lo .= qq|  <status> \n|;
		$geo_lo .= qq|   <geopriv xmlns="urn:ietf:params:xml:ns:pidf:geopriv10"> \n|;
		$geo_lo .= qq|      <location-info> \n|;
		if ($acc) {
		$geo_lo .= qq|          <gs:Circle srsName="urn:ogc:def:crs:EPSG::4326"> \n|;
		$geo_lo .= qq|            <gml:pos>$lat $lon</gml:pos> \n|;
		$geo_lo .= qq|            <gs:radius uom="urn:ogc:def:uom:EPSG::9001">$acc</gs:radius> \n|;
		$geo_lo .= qq|          </gs:Circle> \n|;
		} else {
		$geo_lo .= qq|          <gml:Point srsName="urn:ogc:def:crs:EPSG::4326"> \n|;
		$geo_lo .= qq|            <gml:pos>$lat $lon</gml:pos> \n|;
		$geo_lo .= qq|          </gml:Point> \n|;
		}
		$geo_lo .= qq|      </location-info> \n|;
		$geo_lo .= qq|      <usage-rules/> \n|;
		$geo_lo .= qq|    </geopriv> \n|; 
		$geo_lo .= qq|  </status> \n|;
		$geo_lo .= qq|  <timestamp>$timestamp</timestamp> \n|;
		$geo_lo .= qq|  </tuple> \n|;
	}

	# Create a civic tuple 
	if ($civic)
	{
	
		# Generate a tuple ID
		my $tuple_id = random_id();
		# Compute the timestamp
		my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time);
		my $timestamp = sprintf "%4d-%02d-%02dT%02d:%02d:%02d+00:00", $year+1900, $mon+1, $mday, $hour, $min, $sec;
		# Grab the CATypes
		my $country = ($loc_info{"Country Code"} or $loc_info{"country"});
		my $a1 = ($loc_info{"Region Code"} or $loc_info{"A1"});
		my $a2 = ($loc_info{"County"} or $loc_info{"A2"});
		my $a3 = ($loc_info{"City"} or $loc_info{"A3"});		
		my $rd = $loc_info{"RD"};
		my $sts = $loc_info{"STS"};
		my $pod = $loc_info{"POD"};
		my $hno = $loc_info{"HNO"};
		my $pc = $loc_info{"PC"};
		my $room = $loc_info{"ROOM"};
		my $flr = $loc_info{"FLR"};
		my $loc = $loc_info{"LOC"};

		$civic_lo .= qq|  <tuple id="$tuple_id"> \n|; 
		$civic_lo .= qq|  <status> \n|;
		$civic_lo .= qq|   <geopriv xmlns="urn:ietf:params:xml:ns:pidf:geopriv10"> \n|;
		$civic_lo .= qq|      <location-info> \n|;
		$civic_lo .= qq|        <cl:civicAddress> \n|;
		$civic_lo .= qq|          <cl:country>$country</cl:country> \n| if ($country);
		$civic_lo .= qq|          <cl:A1>$a1</cl:A1> \n| if ($a1);
		$civic_lo .= qq|          <cl:A2>$a2</cl:A2> \n| if ($a2);
		$civic_lo .= qq|          <cl:A3>$a3</cl:A3> \n| if ($a3);
		$civic_lo .= qq|          <cl:RD>$rd</cl:RD> \n| if ($rd);
		$civic_lo .= qq|          <cl:STS>$sts</cl:STS> \n| if ($sts);
		$civic_lo .= qq|          <cl:POD>$pod</cl:POD> \n| if ($pod);
		$civic_lo .= qq|          <cl:HNO>$hno</cl:HNO> \n| if ($hno);
		$civic_lo .= qq|          <cl:PC>$pc</cl:PC> \n| if ($pc);
		$civic_lo .= qq|          <cl:ROOM>$room</cl:ROOM> \n| if ($room);
		$civic_lo .= qq|          <cl:FLR>$flr</cl:FLR> \n| if ($flr);
		$civic_lo .= qq|          <cl:LOC>$loc</cl:LOC> \n| if ($loc);
		$civic_lo .= qq|        </cl:civicAddress> \n|;
		$civic_lo .= qq|      </location-info> \n|;
		$civic_lo .= qq|      <usage-rules/> \n|;
		$civic_lo .= qq|    </geopriv> \n|; 
		$civic_lo .= qq|  </status> \n|;
		$civic_lo .= qq|  <timestamp>$timestamp</timestamp> \n|;
		$civic_lo .= qq|  </tuple> \n|;
	}
	
	# Allocate a location URI
	if ($uri)
	{
		# Check to see if the target is already cached
		my $id = db_rget($ip);
		# If not, generate and store a new id-ip mapping
		if (!$id)
		{
			# Generate a random identifier
			$id = random_id();
			# Cache the id-ip mapping
			db_put($id,$ip);
		}
		
		# Compute an expiry time that's effectively infinite (100yrs)
		my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time);
		my $timestamp = sprintf "%4d-%02d-%02dT%02d:%02d:%02d+00:00", $year+1900+100, $mon+1, $mday, $hour, $min, $sec;
		# Form a held: URI with that ID in the appropriate query field 
		my $new_uri = $my_uri . "?" . $ref_param . "=" . $id;
		# Encapsulate the URI in the approprate XML
		$uri_lo .= qq|<locationUriSet expires="$timestamp">\n|;
		$uri_lo .= qq|  <locationURI>$new_uri</locationURI>\n|;
		$uri_lo .= qq|</locationUriSet>\n|;
	}

	###
	### Step 4: Form the Location Response
	### 	
	my $locationResponse = "";
	$locationResponse .= qq|<?xml version="1.0"?> \n|;
	$locationResponse .= qq|<locationResponse xmlns="urn:ietf:params:xml:ns:geopriv:held"> \n|;
	$locationResponse .= $uri_lo if ($uri);
	if ($geo || $civic) {
		$locationResponse .= $lo_header;
		$locationResponse .= $geo_lo if ($geo);
		$locationResponse .= $civic_lo if ($civic);
		$locationResponse .= $lo_footer;
	}
	$locationResponse .= qq|</locationResponse> \n|;

	###
	### Step 5: Deliver the response
	###
	# We use text/xml for now so that it shows up in a browser
	# (should be application/held+xml)
	my $content_length = length($locationResponse);
	print <<END
Cache-Control: private
Content-Type: application/held+xml 
Content-Length: $content_length

$locationResponse
END
;

	goto done;
	### End of main execution block

	### Jump to here if we have an error
	error:

	my $errorResponse .= "";
	$errorResponse .= qq|<?xml version="1.0"?> \n|;
        $errorResponse .= qq| <error xmlns="urn:ietf:params:xml:ns:geopriv:held" \n|;
        $errorResponse .= qq|        code="$error_code" \n|;
        $errorResponse .= qq|        message="$error_message"/> \n\n|;
	$content_length = length($errorResponse);

	print <<END
Cache-Control: private
Content-Type: text/xml 
Content-Length: $content_length

$errorResponse
END
;
	goto done;

	### The real end of the connection
	done:

	print STDERR "Logging transaction for IP $ip...\n";
	log_transaction($method, $request_uri, $body, $locationResponse, $errorResponse);

###
### END Server Logic
###