File Coverage

blib/lib/Google/OAuth.pm

Criterion	Covered	Total	%
statement	3	3	100.0
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	4	4	100.0

package Google::OAuth ;
use base NoSQL::PL2SQL ;
use Google::OAuth::Config ;
use LWP::UserAgent ;
use JSON ;

use 5.008009;
use strict;
use warnings;

require Exporter;

push @Google::OAuth::ISA,
		qw( Exporter Google::OAuth::Request Google::OAuth::Client ) ;

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Google::OAuth ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw() ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ) ;

our @EXPORT = qw();

our $VERSION = '0.05';


# Preloaded methods go here.

my $duplicate = sub {
	my ( $emailkey, $errorcode, $perldata, $zero, $obj, $errorstring )
			= @_ ;

	my $package = ref $obj ;
	my $u = $package->SQLObject( $emailkey ) ;
	my %keys = map { $_ => 1 } keys %$u, keys %$obj ;

	map { exists $obj->{$_}?
			( $u->{$_} = $obj->{$_} ):
			( delete $u->{$_} ) } keys %keys ;
	return bless $u, $package ;
	} ;

sub SQLClone {
	my $arg = shift ;
	my ( $self, $package ) = ref $arg? ( $arg, ref $arg ): ( undef, $arg ) ;
	$self ||= $package->SQLObject( @_ ) ;

	return bless NoSQL::PL2SQL::SQLClone( $self ), $package ;
	}

sub classID {
	return 0 ;
	}

sub grant_type {
	return 'refresh_token' ;
	}

sub SQLObject {
	my $package = shift ;
	my $email = shift ;
	NoSQL::PL2SQL::SQLError( $email,
			DuplicateObject => $duplicate ) ;
	my @args = ( $email, $package->dsn, $package->classID ) ;

	push @args, bless $_[0], $package if @_ ;
	my $out = NoSQL::PL2SQL::SQLObject( @args ) ;
	return $out? bless( $out, $package ): undef ;
	}

sub grant_code {
	my $package = shift @_ ;
	my $code = shift ;
	my $token = $package->get_token( 'redirect_uri', { code => $code },
			{ grant_type => 'authorization_code' } ) ;

	my $key = $token->emailkey
			if ref $token && $token->{access_token} ;
	return $key? $package->SQLObject( $key => $token ): $token ;
	}

sub token_list {
	my $package = shift ;

	return map { $_->{objecttype} } $package->dsn->fetch(
			[ reftype => 'perldata', 1 ],
			[ objectid => $package->classID ]
			) ;
	}

sub token {
	my $arg = shift ;
	my ( $self, $package ) = ref $arg? ( $arg, ref $arg ): ( undef, $arg ) ;

	my $object = $self ;
	$self ||= $package->SQLObject( @_ ) ;

	my $rr = $package->grant_type ;
	my $token = $package->get_token(
			{ $rr => $self->{$rr} },
			{ grant_type => $rr }
			) ;

	if ( ref $token && $token->{access_token} ) {
		map { $self->{$_} = $token->{$_} } keys %$token ;
		}
	else {
		my $error = ref $token? join( "\n", %$token ): $token ;
		warn join "\n", 'Access renewal failed:', $error, '' ;
		}

	## Object may be a clone
	unless ( defined $self->SQLObjectID ) {
		my $package = ref $self ;
		my $temp = $package->SQLObject( $self->{emailkey} ) ;
		map { $temp->{$_} = $self->{$_} } keys %$self ;
		$self = $temp->SQLClone ;
		}

	return $object || $self->SQLClone ;
	}

sub headers {
	my $self = shift ;
	my $method = shift ;

	return Google::OAuth::Request::headers( $method ),
			Authorization =>
			  join ' ', @$self{ qw( token_type access_token ) } ;
	}

sub emailkey {
	my $self = shift ;
	my $url = 'https://www.googleapis.com'
				.'/calendar/v3/users/me/calendarList' ;
	my $calinfo = $self->content( GET => $url ) ;
	my @owner = grep $_->{accessRole} eq 'owner', @{ $calinfo->{items} } ;
	return $self->{emailkey} = $owner[0]->{summary} ;
	}


package Google::OAuth::Client ;

require Exporter;

@Google::OAuth::Client::ISA = qw( Exporter ) ;

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Google::OAuth ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw() ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ) ;

our @EXPORT = qw() ;

our $VERSION = '0.01';

our %google ;
$google{oauth} = 'https://accounts.google.com/o/oauth2/auth';
$google{token} = 'https://accounts.google.com/o/oauth2/token';

my %client = () ;
setclient() ;

sub setclient {
	my $package = shift ;
	%client = ( Google::OAuth::Config->setclient, @_ ) ;
	return undef ;
	}

sub dsn {
	return $client{dsn} ;
	}

my %scopes = (
	'm8.feeds'
			=> 'https://www.google.com/m8/feeds',
	'calendar'
			=> 'https://www.googleapis.com/auth/calendar',
	'calendar.readonly'
			=> 'https://www.googleapis.com/auth/calendar.readonly',
	'drive.readonly'
			=> 'https://www.googleapis.com/auth/drive.readonly',
	'drive'
			=> 'https://www.googleapis.com/auth/drive',
        ) ;

sub new {
	my $package = shift ;
	my $self = {} ;
	$self->{args} = $package->queryargs( @_ ) if @_ ;
	return bless $self, $package ;
	}

sub scope {
	shift @_ if $_[0] eq __PACKAGE__ ;
	my $self = ref $_[0] eq __PACKAGE__? shift @_: undef ;
	my %args = map { $_ => 1 } ( @_, 'calendar.readonly' ) ;

	my $scope = join ' ', map { $scopes{$_} } keys %args ;
	return $scope unless $self ;

	$self->{scope} = $scope ;
	return $self ;
	}

sub queryargs {
	my $package = shift ;
	my %out = map { ref $_? %$_: ( $_ => $client{$_} ) } @_ ;
	return \%out ;
	}

sub token_request {
	my $self = shift ;
	my $args = $self->{args} || $self->queryargs(
			'client_id', 'redirect_uri',
			{ response_type => 'code' },
			{ approval_prompt => 'force' },
			{ access_type => 'offline' }
			) ;
	$args->{scope} = $self->{scope} if $self->{scope} ;

	my $kurl = @_? shift @_: 'oauth' ;
	return join '?', $google{$kurl} || $kurl,
			Google::OAuth::CGI->new( $args )->query_string ;
	}

sub get_token {
	my $arg = shift ;
	my ( $package, $self ) = ref $arg?
			( ref $arg, $arg ):
			( $arg,
			  new( $arg, 'client_id', 'client_secret', @_ ) ) ;

	my $out = Google::OAuth::Request->content(
			POST => $google{token},
			Google::OAuth::CGI->new( $self->{args} )->query_string
			) ;

	return $out unless ref $out ;
	$out->{requested} = time ;
	return bless $out, $package ;
	}

sub expired {
	my $self = shift ;
	return $self->{requested} +$self->{expires_in} < time ;
	}


package Google::OAuth::Request ;

my %content_type = () ;
$content_type{POST} = 'application/x-www-form-urlencoded' ;
$content_type{GET} = 'application/http' ;

sub request {
	my $self = shift ;
	my $method = @_ > 1? shift @_: 'GET' ;
	my $url = shift ;

	my %hh = $self->headers( $method ) ;
	$hh{'Content-Type'} = shift @_ if @_ > 1 ;
	$hh{'Content-Length'} = length $_[0] if $method eq 'POST' ;

	my @args = grep defined $_, ( [ %hh ], @_ ) ;
	return new HTTP::Request( $method, $url, @args ) ;
	}

sub response {
	my $self = shift ;
	my $r = $self->request( @_ ) ;
	return LWP::UserAgent->new->request( $r ) ;
	}

sub content {
	my $self = shift ;
	my $content = $self->response( @_ )->content ;
	return $content unless $content =~ /^{/s ;
	return JSON::from_json( $content ) ;
	}

sub headers {
	shift @_ if $_[0] eq __PACKAGE__ ;
	shift @_ if ref $_[0] eq __PACKAGE__ ;

	my $method = shift ;

	return (
		'Content-Type' => $content_type{$method},
		) ;
	}


## stupid CGI::Simple fails on mod_perl
## replace with a published distro
package Google::OAuth::CGI ;

sub new {
	my $package = shift ;
	my $source = shift ;
	return bless { source => $source }, $package ;
	}

sub encode {
	shift @_ if $_[0] eq __PACKAGE__ ;
	my $text = shift ;
	$text =~ s|([^_0-9A-Za-z\. ])|sprintf "%%%02X", ord($1)|seg ;
	$text =~ s/ /+/g ;
	return $text ;
	}

sub args {
	my ( $key, $value ) = @_ ;
	$value ||= '' ;
	return join '=', $key, encode( $value ) unless ref $value ;

	if ( ref $value eq 'ARRAY' ) {}
	elsif ( grep ref $value eq $_, qw( HASH SCALAR ) ) {
		return '' ;
		}
	elsif ( $value->isa('ARRAY') ) {}
	else {
		return '' ;
		}

	return join '&', map { join '=', $key, encode( $_ ) } @$value ;
	}

sub query_string {
	my $self = shift ;
	my $source = $self->{source} ;

	return join '&', map { args( $_, $source->{$_} ) } keys %$source ;
	}


1;
__END__