package WebService::Sprint;

use warnings;
use strict;

=head1 NAME

WebService::Sprint - an interface to Sprint's web services

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

use DateTime;
use Digest::MD5 qw(md5_hex);
use LWP::Simple;
use LWP::UserAgent;
use JSON;
use URI;

my %DEFAULTS = (
	base_url =>
	"http://sprintdevelopersandbox.com/developerSandbox/resources/v1/",
	user_agent => "WebService::Sprint",
);

my %SERVICES = (
	location  => 'location.json',
	presence  => 'presence.json',
	perimeter => 'geofence/checkPerimeter.json',
	devices   => 'devices.json',
);

=head1 SYNOPSIS

Provides an object-oriented interface to Sprint's developer web services, including geolocation of Sprint devices.

Disclaimer: I am not affiliated with Sprint. This is an implementation of their publicly-available specifications. Sprint is probably a registered trademark, and is used here to highlight that this implementation is specific to the Sprint network.

Implements some features of Sprint's developer web services. For more information, see:
 http://developer.sprint.com/site/global/sandbox/home.jsp
 http://developer.sprint.com/site/global/sandbox/sprint_services/sprint_services.jsp

Currently supports:
 - presence
 - location (3G)
 - Geofence perimiter check
 - User management -- retrieving list of devices

Does not support:
 - All other geofence operations
 - SMS
 - User management -- adding or removing devices
 - iDen Content Uploader

		use WebService::Sprint;

		my $ws = WebService::Sprint->new(
			key 	 => '0123456789abcdef',
			secret => 'fedcba98765432100123456789abcdef',
		);

		# Get the list of devices associated with your developer account
		my $devices = $ws->get_devices(
			type   => 'approved',
		);

		# Fetch the network location of a single device
		my $location = $ws->get_location(
			mdn    => '2225551212',
		);

		# Fetch the location of multiple devices (issues multiple queries behind the scenes, serially)
		my @locations = $ws->get_location(
			mdn    => [qw(2225551212 8885551234)],
		);

		# Check whether a device is within a given geofence
		my $presence = $ws->check_presence(
			mdn       => '2225551212',

			# Geofence coordinates
			latitude  => 45.000,
			longitude => -120.000,

			# Radius (seems to need to be more than 2000m)
			radius    => 5000,
		);

=head1 METHODS

=head2 new

Instantiates a Web Service object. Named arguments include:
	key: Your Sprint-assigned developer key
	secret: Your Sprint-assigned shared secret
	base_url: The base URL for Sprint services (defaults to http://sprintdevelopersandbox.com/developerSandbox/resources/v1/)
	user_agent: HTTP user agent used (defaults to WebService::Sprint)

=cut

sub new {
	my ( $class, @args ) = @_;

	if ( @args % 2 ) {
		die "Arguments must be valid name-value pairs";
	}

	my %args = @args;

	my $self = {};

	_get_defaults( $self, \%args );

	bless $self, $class;

	return $self;

}

sub _get_defaults {
	my ( $dst, $src ) = @_;

	if (  !defined $dst
		|| ref $dst ne 'HASH'
		|| !defined $src
		|| ref $src ne 'HASH' )
	{
		die "Invalid parameters";
	}

	while ( my ( $name, $value ) = each %DEFAULTS ) {
		$dst->{$name} = $value;
	}

	while ( my ( $name, $value ) = each %{$src} ) {
		$dst->{$name} = $value;
	}

	return;
}

=head2 get_devices

Given no arguments, returns a hashref of devices associated with your developer account, indicating status.
Given the argument mdn with a valid 10-digit phone number, returns information about that device only.
Given the argument type (pending, declined, deleted, approved, all), returns information about only that subset of devices associated with your account.

=cut

sub get_devices {
	my ($self, %args) = @_;

	my %params = (
		service => 'devices',
	);

	my $mdn;
	if (defined $args{mdn})
	{
		if ($mdn = _clean_mdn($args{mdn})) {
			$params{type} = 'mdn';
			$params{mdn}  = $mdn;
		}
		else
		{
			die "Invalid MDN: $args{mdn}\n";
		}
	}
	else
	{
		if (defined $args{type})
		{
			$params{type} =
			($args{type} =~ m/^p(?:ending)?/i)  ? 'p' :
			($args{type} =~ m/^dec(?:lined)?/i) ? 'x' :
			($args{type} =~ m/^del(?:eted)?/i)  ? 'd' :
			($args{type} =~ m/^ap(?:proved)/i)  ? 'a' :
			($args{type} =~ m/^al(?:l)/i)       ? 'null' :
			die "Invalid type: $args{type}\n";
		}
	}

	my $devices = $self->issue_query(
		service => 'devices',
		params => \%params,
	);

	my %devices = (
		original => $devices,
		timestamp => time,
	);
	my @devices;

	$devices{auth_status} = lc _best_match($devices, qr/^auth.?status/i);
	my $device_list = $devices->{devices};
	if (defined $device_list)
	{
		if (ref $device_list eq 'HASH')
		{
			while (my ($status, $list) = each %{$device_list})
			{
				if (defined $list && ref $list eq 'ARRAY')
				{
					foreach my $mdn (@{$list})
					{
						push(@devices, {
								mdn => $mdn,
								status => lc $status,
							},
						);
					}
				}
			}
		}
		elsif (ref $device_list eq 'ARRAY')
		{
			foreach my $mdn (@{$device_list})
			{
				push(@devices, {
						mdn => $mdn,
						status => $devices{auth_status},
					},
				);
			}
		}
		else
		{
			$devices{devices} = $device_list;
		}
	}

	$devices{devices} = \@devices;
	$devices{username} = _best_match($devices, qr/^username/i);
	$devices{error} = _best_match($devices, qr/^error/i);

	return \%devices;
}

=head2 get_presence

Given the argument mdn as a single or list of 10-digit phone numbers, returns a hashref (or list of hashrefs) with detailed information about the presence of the requested device on the Sprint network.

This call should not use your credits.

=cut

sub get_presence {
	my ($self, %args) = @_;

	if (! defined $args{mdn})
	{
		return;
	}

	if (ref $args{mdn} eq 'ARRAY')
	{
		my @response;
		foreach my $mdn (@{$args{mdn}})
		{
			push(@response, $self->get_presence(mdn => $mdn));
		}
		return @response;
	}

	if (my $mdn = _clean_mdn($args{mdn}))
	{
		my $presence = $self->issue_query(
			service => 'presence',
			params => {
				mdn => $mdn,
			},
		);

		my %presence = (
			original => $presence,
			mdn => $mdn,
			timestamp => time,
		);

		$presence{error}     = _best_match($presence, qr/^error/i);

		my $reachable = _best_match($presence, qr/^status/i);
		$presence{reachable} = ($reachable && $reachable =~ m/^reachable/i) ? 1 : 0;

		my $response_mdn = _best_match($presence, qr/^mdn/i);
		if (defined $response_mdn && $mdn ne $response_mdn)
		{
			die "Response received for incorrect MDN: $response_mdn\n";
		}

		return \%presence;
	}
	else
	{
		die "Invalid MDN: $args{mdn}\n";
	}
}

=head2 get_location

Given the argument mdn as a single or list of 10-digit phone numbers, returns a hashref (or list of hashrefs) with detailed information about the network-based location of the requested device.

WARNING: This uses credits (3 per device query, last I checked)!

=cut

sub get_location {
	my ($self, %args) = @_;

	if (! defined $args{mdn})
	{
		return;
	}

	if (ref $args{mdn} eq 'ARRAY')
	{
		my @response;
		foreach my $mdn (@{$args{mdn}})
		{
			push(@response, $self->get_location(mdn => $mdn));
		}
		return @response;
	}

	if (my $mdn = _clean_mdn($args{mdn}))
	{
		my $location = $self->issue_query(
			service => 'location',
			params => {
				mdn => $mdn,
			},
		);

		my %location = (
			original => $location,
			mdn => $mdn,
			timestamp => time,
		);

		$location{error}     = _best_match($location, qr/^error/i);
		$location{latitude}  = _best_match($location, qr/^lat/i);
		$location{longitude} = _best_match($location, qr/^lon/i);
		$location{accuracy}  = _best_match($location, qr/^accuracy/i);
		if (_best_match($location, qr/^old/i))
		{
			$location{old}++;
		}

		my $response_mdn = _best_match($location, qr/^mdn/i);
		if (defined $response_mdn && $mdn ne $response_mdn)
		{
			die "Response received for incorrect MDN: $response_mdn\n";
		}

		return \%location;
	}
	else
	{
		die "Invalid MDN: $args{mdn}\n";
	}
} 

=head2 check_perimeter

Works similarly to get_location, but is intended to determine whether a given device is within a specified geofence. Takes the additional (required) parameters latitude, longitude (both in decimal degrees), and range (in meters). Returns location information, the specified geofence, and whether the device is inside the defined fence.

This is a distincly different service call to Sprint, even though it could be implemented with some geo-math around get_location. Specifically, this service call attempts to obtain a higher-precision location, and consequently, Sprint charges more credits for its use.

WARNING: This uses credits (6 per device query, last I checked)!

=cut

sub check_perimeter {
	my ($self, %args) = @_;

	if (! defined $args{mdn})
	{
		return;
	}

	my $latitude = _find_defined(@args{qw(lat latitude)})
		or die "Latitude not provided";

	if (!_in_range($latitude, -90, 90))
	{
		die "Invalid latitude: $latitude\n";
	}

	my $longitude = _find_defined(@args{qw(lon longitude long)})
		or die "Longitude not provided";

	if (!_in_range($longitude, -180, 180))
	{
		die "Invalid longitude: $longitude\n";
	}

	my $radius = _find_defined(@args{qw(rad radius range)})
		or die "Radius not provided";

	if (!_in_range($radius, 2000, undef))
	{
		die "Invalid radius: $radius\n";
	}

	if (ref $args{mdn} eq 'ARRAY')
	{
		my @mdns = @{$args{mdn}};

		my @response;

		foreach my $mdn (@mdns)
		{
			push(@response, $self->check_perimeter(
					%args,
					mdn => $mdn,
				),
			);
		}
		return @response;
	}

	if (my $mdn = _clean_mdn($args{mdn}))
	{
		my $status = $self->issue_query(
			service => 'perimeter',
			params => {
				mdn => $mdn,
				lat => $latitude,
				long => $longitude,
				rad => $radius,
			},
		);

		my %status = (
			original => $status,
			mdn => $mdn,
			timestamp => time,
		);

		$status{error}     = _best_match($status, qr/^error/i);
		$status{latitude}  = _best_match($status, qr/^lat/i);
		$status{longitude} = _best_match($status, qr/^lon/i);
		$status{accuracy}  = _best_match($status, qr/^accuracy/i);
		$status{comment}   = _best_match($status, qr/^comment/i);

		my $inside = _best_match($status, qr/^currentlocation/i);
		$status{inside}    = ($inside && $inside =~ m/inside/i) ? 1 : 0;

		if (!$status{error} && $inside =~ qr/fail/i)
		{
			$status{error} = $inside;
		}

		$status{perimeter} = {
			radius => _best_match($status, qr/^radius/i) || undef,
			latitude => _best_match($status, qr/^glat/i) || undef,
			longitude => _best_match($status, qr/^glong/i) || undef,
		};

		my $response_mdn = _best_match($status, qr/^mdn/i);
		if (defined $response_mdn && $mdn ne $response_mdn)
		{
			die "Response received for incorrect MDN: $response_mdn\n";
		}

		return \%status;
	}
	else
	{
		die "Invalid MDN: $args{mdn}\n";
	}
}

=head1 EXTRA METHODS

These are underlying methods that may be useful to extend this module for use with additional services.

=head2 issue_query

Given a list of named arguments, issues a web service request. Calling this method takes care of timestamp and authentication/hashing requirements for you.
Provided for your convenience to access unimplemented services.

=cut

sub issue_query {
	my ($self, %args) = @_;

	my $url = $self->build_url(%args);
	#warn "URL: $url\n";

	my $response = $self->fetch_url(
		url => $url,
	);
	#warn "Response: $response\n";

	my $output = $self->decode_response(
		json => $response,
	);

	return $output;
}

=head2 build_url

Given a list of named arguments, constructs the service URL, adding the timestamp and hash. Called by issue_query, and provided for your convenience.

=cut

sub build_url {
	my ($self, %args) = @_;

	if (! defined $SERVICES{$args{service}})
	{
		die "Invalid service $args{service}\n";
	}

	my $dt = DateTime->now->set_time_zone('local');

	my %params = (
		key => $self->get_key,
		timestamp => $dt->iso8601.$dt->time_zone_short_name,
	);

	while (my ($key, $value) = each %{$args{params}})
	{
		$params{$key} = $value;
	}

	my $hash = $self->get_hash(%params);

	my $uri = URI->new($self->{base_url}.$SERVICES{$args{service}});

	$uri->query_form(
		%params,
		sig => $hash,
	);

	return $uri;
}

=head2 fetch_url

Given a named argument url, retrieves the URL. If successful, returns the content. If failed, returns the status message. Called by issue_query, and provided for your convenience.

=cut

sub fetch_url {
	my ($self, %args) = @_;

	my $url = $args{url}
		or die "No URL to fetch";

	my $ua = LWP::UserAgent->new
		or die "Failed to create a User Agent\n";

	$ua->agent($self->{user_agent});

	my $req = HTTP::Request->new(GET => $url);

	my $res = $ua->request($req);

	my $json;
	my $output;

	if ($res->is_success)
	{
		return $res->content;
	}
	else
	{
		die $res->status_line;
	}
}

=head2 decode_response

Given a named argument json containing the JSON response from a web service query, attempts to decode the JSON into a hash ref. Attempts to remove the extraneous line feeds that appear in some responses.

=cut

sub decode_response {
	my ($self, %args) = @_;

	if (! defined $args{json})
	{
		die "No response found";
	}

	my $output;

	DECODE_JSON:
	{
		eval {
			$output = decode_json($args{json});
		};
		if ($@)
		{
			if ($args{json} =~ tr/\n\r//d)
			{
				warn "Trimmed line feeds from JSON response for compatibility\n";
				redo DECODE_JSON;
			}
			else
			{
				die "$@\nRaw JSON: $args{json}\n";
			}
		}
	}

	return $output;
}

=head2 get_hash

Given a named argument list, orders the keys and calculates the authentication hash, based on the shared secret. This method is called internally when building a request URI, but is provided for your convenience.

=cut

sub get_hash {
	my ($self, %args) = @_;

	my $secret = $self->get_secret
		or die "No secret available";

	my @hash_data;
	foreach my $key (sort keys %args)
	{
		push(@hash_data, $key, $args{$key});
	}
	my $hash = md5_hex(join('', @hash_data, $secret));

	return $hash;
}

=head2 get_key

Returns the object's stored key. Provided for your convenience

=cut

sub get_key {
	my ($self) = @_;

	if (! defined $self->{key})
	{
		die "Key must be defined!\n";
	}

	return $self->{key};
}

=head2 get_secret

Retuns the object's stored shared secret. Provided for your convenience.

=cut

sub get_secret {
	my ($self) = @_;

	if (!defined $self->{secret})
	{
		die "Secret must be defined!\n";
	}

	return $self->{secret};
}

=head1 AUTHOR

Brett T. Warden, C<< <bwarden at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-webservice-sprint at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=WebService-Sprint>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc WebService::Sprint


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=WebService-Sprint>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/WebService-Sprint>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/WebService-Sprint>

=item * Search CPAN

L<http://search.cpan.org/dist/WebService-Sprint/>

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2011 Brett T. Warden.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

# Sanitizes an mdn
sub _clean_mdn {
	my ($orig_mdn) = @_;

	# Strip unseemly characters
	$orig_mdn =~ s/[\s()]//g;

	if (my @parts =
		($orig_mdn =~ m/^(?:\+?1)?[\-\.]?(\d{3})[\-\.]?(\d{3})[\-\.]?(\d{4})$/))
	{
		return join('', @parts);
	}
	else
	{
		return;
	}
}

# Returns the first defined argument in the argument list
sub _find_defined {
	foreach my $arg (@_)
	{
		if (defined $arg)
		{
			return $arg;
		}
	}
	return;
}

# Determines whether the supplied number is in the supplied range.
sub _in_range {
	my ($number, $lower, $upper) = @_;

	if ($number !~ m/^-?\d+(\.\d*)?$/)
	{
		die "Not a floating point number: $number\n";
	}

	if (defined $lower)
	{
		if ($number < $lower)
		{
			return;
		}
	}

	if (defined $upper)
	{
		if ($number > $upper)
		{
			return;
		}
	}

	return 1;
}

# Returns the value from the supplied hashref whose key best matches the supplied regex
sub _best_match {
	my ($h, $re) = @_;

	if (ref $h ne 'HASH')
	{
		return;
	}

	if (ref $re ne 'Regexp')
	{
		die "$re is not a Regular Expression";
	}

	KEY:
	foreach my $key (sort _by_length keys %{$h})
	{
		if ($key =~ $re)
		{
			return $h->{$key};
		}
	}

	return;
}

# Sorting helper function to order arguments by length
sub _by_length {
	my $a_len = 0;
	my $b_len = 0;

	if (defined $a)
	{
		$a_len = length $a;
	}
	if (defined $b)
	{
		$b_len = length $b;
	}

	return $a_len <=> $b_len;
}

1; # End of WebService::Sprint
