File Coverage

blib/lib/Google/ProvisioningAPI.pm

Criterion	Covered	Total	%
statement	25	27	92.5
branch			n/a
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	34	36	94.4

#A class that encapsulates the Google Apps for Your Domain Provisioning API V1.0
#see http://code.google.com/apis/apps-for-your-domain/google_apps_provisioning_api_v1.0_reference.html
#(C) 2006 Johan Reinalda, johan at reinalda dot net
#
#skeleton generated with h2xs -AXc -n Google::ProvisioningAPI
#
package Google::ProvisioningAPI;

use 5.008005;

use strict;
use warnings;
use vars qw($VERSION);

use Carp;
use LWP::UserAgent qw(:strict);
use HTTP::Request qw(:strict);
use Encode;
use XML::Simple;

#I don't see the need for this - JKR
#require Exporter;

#NOT NEEDED FOR THIS CLASS
#our @ISA = qw(Exporter AutoLoader);

# 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::ProvisioningAPI ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.

#I don't see the need for this - JKR
#our %EXPORT_TAGS = ( 'all' => [ qw(
#
#) ] );
#
#our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
#
#our @EXPORT = qw(
#
#);

our $VERSION = '0.11';
our $APIVersion = '1.0';

#some constants
#web agent identification
use constant GOOGLEAGENT => 'Google_ProvisioningAPI-perl/0.11';

#url for Google API token login
use constant GOOGLEHOST => 'www.google.com';
use constant GOOGLETOKENURL => 'https://www.google.com/accounts/ClientLogin';
use constant MAXTOKENAGE => 24 * 60 * 60;	#24 hours, see API docs

#base url to the Google REST API
use constant GOOGLEBASEURL => 'https://www.google.com/a/services/v1.0/';

use constant SUCCESSCODE => 'Success(2000)';
use constant FAILURECODE => 'Failure(2001)';

#some size constants
use constant MAXNAMELEN => 40;
use constant MAXUSERNAMELEN => 30;


# Preloaded methods go here.

#the constructor
sub new
{
	#parse parameters, if any
	(@_ == 4) || croak 'Constructor takes 3 arguments: domain, admin, adminpassword';

	my $object = shift();
	my $class = ref($object) || $object;

	my $self = {
		#Google related variables
		domain => shift(),		#the Google hosted domain we are accessing
		admin => shift(),		#the account to use when authenticating
		password => shift(),	#the password to use when authenticating
		refreshtoken => 0,		#if set, will force a re-authentication
		authtoken => '',		#the authentication token returned from google
		authtime => 0,			#time when authentication happened; only valid for 24 hours
		requestcontent => '',	#the last http content posted to Google
		replyheaders => '',		#the http headers of the last reply
		replycontent => '',		#the http content of the last reply
		result => {},			#the resulting hash from the last reply data as parsed by XML::Simple

		#some other variables
		debug => 0,			#when turned on, will spit out debug info to STDERR

		#some statistics that are 'read-only'
		stats => {
			ctime =>  time,			#object creation time
			rtime => 0,				#time of last request
			requests => 0,			#number of API requests made
			success => 0,			#number of successes
			logins => 0,			#number of authentications performed
		}
	};
	#return object
	bless( $self, 'Google::ProvisioningAPI');
	return $self;

}

#method used to (re)login to the API, either first time, or as token times out
sub Relogin
{

	#get object reference
	my $self = shift();

	$self->dprint("Relogin called\n");

	my $retval = 0;

	#adjust stats counter
	$self->{stats}->{logins}++;

	#clear last results
	$self->{replyheaders} = $self->{replycontent} = '';
	$self->{result} = {};

	# Create an LWP object to make the HTTP POST request
	my $lwp = LWP::UserAgent->new;

	if(defined($lwp)) {
		$lwp->agent(GOOGLEAGENT);
		$lwp->from($self->{admin}.'@'.$self->{domain});
		# Submit the request with values for
		# accountType, Email and Passwd variables.
		my $response = $lwp->post( GOOGLETOKENURL,
				[ 'accountType' => 'HOSTED',
				  'Email' => $self->{admin}.'@'.$self->{domain},
				  'Passwd' => $self->{password}
				]
			);
		#save reply page
		$self->{replyheaders} = $response->headers->as_string;
		$self->{replycontent} = $response->content;

		if ($response->is_success) {
			# Extract the authentication token from the response
			foreach my $line (split/\n/, $response->content) {
				#$self->dprint( "RECV'd: $line" );
				if ($line =~ m/^SID=(.+)$/) {
					$self->{authtoken} = $1;
					$self->{authtime} = time;
					$self->dprint("Token found: $self->{authtoken}\n");
					#clear refresh
					$self->{refreshtoken} = 0;
					$retval = 1;
					last;
				}
			}
		}
		else {
			$self->dprint("Error in login: " . $response->status_line . "\n");
			$self->{result}->{reason} = "Error in login: " . $response->status_line;

		}
	} else {
		$self->dprint("Error getting lwp object: $!\n");
		$self->{result}->{reason} = "Error getting lwp object: $!";
	}
	return $retval;
}



#check if we are authenticated. If not, try to re-login
sub IsAuthenticated {

	#get object reference
	my $self = shift();

	if( $self->{refreshtoken} or ( (time - $self->{authtime}) > MAXTOKENAGE ) ) {
		return $self->Relogin();
	}
	#we are still okay!
	return 1;
}

#generic request routine that handles most functionality
#requires 3 arguments: Type, Action, Body
#Type is the object type to action upon. ('Account', 'Alias', 'MailingList')
#Action is what needs to be done
#Body is the xml specific to the action
sub Request
{
	my $retval = 0;

	#get object reference
	my $self = shift();

	$self->dprint( "***REQUEST***\n");

	#clear last results
	$self->{replyheaders} = $self->{replycontent} = '';
	$self->{result} = {};

	if(@_ != 3) {
		$self->{result}->{reason} = 'Invalid number of arguments to request()';
		return 0;
	}

	#get parameters
	my($type,$action,$body) = @_;

	$self->dprint( "Type: $type\nAction: $action\n$body\n");

	#keep some stats
	$self->{stats}->{requests}++;
	$self->{stats}->{rtime} = time;

	#check if we are authenticated to google
	if(!$self->IsAuthenticated()) {
		$self->dprint( "Error authenticating\n");
		return 0;
	}

	#standard XML pre and post segments
	my $pre = <<"EOL";


		xmlns:xsi=\"http:\/\/www.w3.org\/2001\/XMLSchema-instance\">
	$type<\/hs:type>
	$self->{authtoken}
	$self->{domain}
EOL

	my $post = '';


	#create to request body
	$body = $pre . $body . $post;
	#properly encode it
	$body = encode('UTF-8',$body);

	#save the request content
	$self->{requestcontent} = $body;

	# Create an LWP object to make the HTTP POST request over
	my($ua) = LWP::UserAgent->new;
	if(!defined($ua)) {
		$self->dprint("Cannot create LWP::UserAgent object: $!\n");
		$self->{result}->{reason} = "Cannot create LWP::UserAgent object in request(): $!";
		return $retval;
	}

	#and create the request object where are we connecting to
	my $url = GOOGLEBASEURL . $action;
	$self->dprint("URL: $url\n");
	my $req = HTTP::Request->new(POST => $url);
	if(!defined($req)) {
		$self->dprint("Cannot create HTTP::Request object: $!\n");
		$self->{result}->{reason} = "Cannot create HTTP::Request object in request(): $!";
		return $retval;
	}

	#set some user agent variables
	$ua->agent( GOOGLEAGENT );
	$ua->from( '<' . $self->{admin}.'@'.$self->{domain} . '>');

	# Submit the request with values for
	# accountType, Email and Passwd variables.
	#$req->header('ContentType' => 'application/x-www-form-urlencoded');
	$req->header('Content-Type' => 'application/xml');
	$req->header('Accept' => 'application/xml');
	$req->header('Content-Lenght' => length($body) );
	$req->header('Connection' => 'Keep-Alive');
	$req->header('Host' => GOOGLEHOST);
	#assign the data to the request
	$req->content($body);

	#execute the request
	my $response = $ua->request($req);
	#save reply page
	$self->{replyheaders} = $response->headers->as_string;
	$self->{replycontent} = $response->content;
	#check result
	if ($response->is_success) {
		$self->{stats}->{success}++;
		$self->dprint( "Success in post:\n");

		#delete all namespace elements to keep it simple (ie. remove "hs:")
		#this avoids the need to use XML::NameSpace
		my $xml = decode('UTF-8', $response->content);
		$xml =~ s/hs\://g;
		$self->dprint( $xml );

		#now go parse it using XML::Simple
		$self->{result} = XMLin($xml,ForceArray => 0);
		#include Data::Dumper above if you want to use this line:
		#$self->dprint( Dumper($self->{result}) );

		#see if this was a successful call
		if( defined($self->{result}->{status}) and $self->{result}->{status} eq SUCCESSCODE ) {
			$self->dprint("Google API success!");
			$retval = 1;
		} else {
			$self->dprint("Google API failure!");
			if(defined($self->{result}->{reason})) {
				$@ = "Google API failure: $self->{result}->{status} - $self->{result}->{reason}";
			} else {
				$@ = "Google API failure: reason not found!";
				$self->{result}->{reason} = "Google API failure: reason not found!";
			}
		}
	}
	else {
		$self->dprint( "Error in post: " . $response->status_line . "\n");
		$self->{result}->{reason} = "Error in http post: " . $response->status_line;
	}
	#show full response for now
	#$self->dprint( "Headers:\n" . $response->headers->as_string);
	#foreach my $line (split/\n/, $response->content) {
	#	$self->dprint( "RECV'd:   $line\n");
	#}

	return $retval;
}


######################################
### these are the actual API calls ###
### See the Google docs for more   ###
######################################


### HOSTED ACCOUNT routines ###

sub CreateAccountEmail
{
	#get object reference
	my $self = shift();

	$self->dprint( "CreateAccount called\n");

	#check remaining arguments
	if(@_ < 4) {
		$self->dprint( "CreateAccountEmail method requires at least 4 arguments!\n");
		$self->{result}->{reason} = "CreateAccountEmail method requires at least 4 arguments!";
		return 0;
	}

	#get arguments
    my $userName = shift();
	my $firstName = shift();
    my $lastName = shift();
    my $password = shift();
	my $quota = shift() if (@_);	#this one is optional

	my $body = <<"EOL";

		$firstName
		$lastName
		$password
		$userName
EOL

	if(defined($quota)) {
		$body .= "\t\t$quota<\/hs:quota>\n";
	}

	#add the final end-of-section tab
	$body .= "\t<\/hs:CreateSection>\n";


	return $self->Request('Account','Create/Account/Email',$body);

}

#NOTE: this API call may be discontinued!
sub CreateAccount
{
	#get object reference
	my $self = shift();

	$self->dprint( "CreateAccount called\n");

	#check remaining arguments
	if(@_ != 4) {
		$self->dprint( "CreateAccount method requires 4 arguments!\n");
		$self->{result}->{reason} = "CreateAccount method requires 4 arguments!";
		return 0;
	}

	#get arguments
    my $userName = shift();
	my $firstName = shift();
    my $lastName = shift();
    my $password = shift();

	my $body = <<"EOL";

		$firstName
		$lastName
		$password
		$userName

EOL

	return $self->Request('Account','Create/Account',$body);

}

sub UpdateAccount
{
	#get object reference
	my $self = shift();

	$self->dprint( "UpdateAccount called\n");

	#check remaining arguments
	if(@_ != 4) {
		$self->dprint( "UpdateAccount method requires 4 arguments!\n");
		$self->{result}->{reason} = "UpdateAccount method requires 4 arguments!";
		return 0;
	}

	#get arguments
    my $userName = shift();
	my $firstName = shift();
    my $lastName = shift();
    my $password = shift();

	#build request body
	my $body = <<"EOL";
	userName
	$userName

EOL

	if(defined($firstName)) {
		$body .= "\t\t$firstName<\/hs:firstName>\n";
	}
	if(defined($lastName)) {
		$body .= "\t\t$lastName<\/hs:lastName>\n";
	}
	if(defined($password)) {
		$body .= "\t\t$password<\/hs:password>\n";
	}

	#add the final end-of-section tab
	$body .= "\t<\/hs:UpdateSection>\n";


	return $self->Request('Account','Update/Account',$body);

}

sub UpdateAccountEmail
{
	#get object reference
	my $self = shift();

	$self->dprint( "UpdateAccountEmail called\n");

	#check remaining arguments
	if(@_ != 1) {
		$self->dprint( "UpdateAccount method requires 1 argument!\n");
		$self->{result}->{reason} = "CreateAccount method requires 1 argument!";
		return 0;
	}

	#get arguments
    my $userName = shift();

	my $body = <<"EOL";
	userName
	$userName

		1

EOL

	return $self->Request('Account','Update/Account/Email',$body);

}

sub UpdateAccountStatus
{
	#get object reference
	my $self = shift();

	$self->dprint( "UpdateAccountStatus called\n");

	#check remaining arguments
	if(@_ != 2) {
		$self->dprint( "UpdateAccount method requires 2 argument!\n");
		$self->{result}->{reason} = "CreateAccount method requires 2 arguments!";
		return 0;
	}

	#get arguments
    my $userName = shift();
	my $status = shift();

	if($status ne 'locked' and $status ne 'unlocked') {
		$self->dprint( "Error: status invalid!\n");
		$self->{result}->{reason} = 'Invalid status';
		return 0;
	}

	my $body = <<"EOL";
	userName
	$userName

		$status

EOL

	return $self->Request('Account','Update/Account/Status',$body);

}

sub RetrieveAccount
{
	#get object reference
	my $self = shift();

	$self->dprint( "RetrieveAccount called\n");

	#check remaining arguments
	if(@_ != 1) {
		$self->dprint( "RetrieveAccount method requires 1 argument!\n");
		$self->{result}->{reason} = "RetrieveAccount method requires 1 argument!";
		return 0;
	}

	#get argument
    my $userName = shift();

	my $body = <<"EOL";
	userName
	$userName
EOL

	return $self->Request('Account','Retrieve/Account',$body);
}


sub DeleteAccount
{
	#get object reference
	my $self = shift();

	$self->dprint( "DeleteAccount called\n");

	#check remaining arguments
	if(@_ != 1) {
		$self->dprint( "DeleteAccount method requires 1 argument!\n");
		$self->{result}->{reason} = "DeleteAccount method requires 1 argument!";
		return 0;
	}

	#get argument
    my $userName = shift();

	my $body = <<"EOL";
	userName
	$userName
EOL

	return $self->Request('Account','Delete/Account',$body);
}

sub RenameAccount
{
#This is derived from the Python sample code:
#-----
#Username change. Note that this feature must be explicitly
#   enabled by the domain administrator, and is not enabled by
#   default.
#
#   Args:
#     oldname: user to rename
#     newname: new username to set for the user
#     alias: if 1, create an alias of oldname for newname
#-----
#Ie. this may not work yet - JKR 20061204

	#get object reference
	my $self = shift();

	$self->dprint( "RenameAccount called\n");

	#check remaining arguments
	if(@_ != 3) {
		$self->dprint( "RenameAccount method requires 3 arguments!\n");
		$self->{result}->{reason} = "RenameAccount method requires 3 arguments!";
		return 0;
	}

	#get arguments
    my $oldName = shift();
    my $newName = shift();
    my $alias = shift();
	#check format of alias; default to 0
	$alias = lc($alias);
	if($alias ne '1') { $alias = '0'; }

	#build request format
	my $body = <<"EOL";
	userName
	$oldName

		$newName
		$alias

EOL

	return $self->Request('Account','Update/Account/Username',$body);
}


### ALIAS routines ###

sub CreateAlias
{
	#get object reference
	my $self = shift();

	$self->dprint( "CreateAlias called\n");

	#check remaining arguments
	if(@_ != 2) {
		$self->dprint( "CreateAlias method requires 2 arguments!\n");
		$self->{result}->{reason} = "CreateAlias method requires 2 arguments!";
		return 0;
	}

	#get argument
    my $userName = shift();
	my $alias = shift();

	#create the command format
	my $body = <<"EOL";

		$userName
		$alias

EOL

	return $self->Request('Alias','Create/Alias',$body);
}

sub RetrieveAlias
{
	#get object reference
	my $self = shift();

	$self->dprint( "RetrieveAlias called\n");

	#check remaining arguments
	if(@_ != 1) {
		$self->dprint( "RetrieveAlias method requires 1 argument!\n");
		$self->{result}->{reason} = "RetrieveAlias method requires 1 argument!";
		return 0;
	}

	#get argument
    my $userName = shift();

	my $body = <<"EOL";
	aliasName
	$userName
EOL

	return $self->Request('Alias','Retrieve/Alias',$body);
}

sub DeleteAlias
{
	#get object reference
	my $self = shift();

	$self->dprint( "DeleteAlias called\n");

	#check remaining arguments
	if(@_ != 1) {
		$self->dprint( "DeleteAlias method requires 1 argument!\n");
		$self->{result}->{reason} = "DeleteAlias method requires 1 argument!";
		return 0;
	}

	#get arguments
    my $alias = shift();

	my $body = <<"EOL";
	aliasName
	$alias
EOL

	return $self->Request('Alias','Delete/Alias',$body);
}


### Mailing List routines


sub CreateMailingList
{
	#get object reference
	my $self = shift();

	$self->dprint( "CreateMailingList called\n");

	#check remaining arguments
	if(@_ != 1) {
		$self->dprint( "CreateMailingList method requires 1 argument!\n");
		$self->{result}->{reason} = "CreateMailingList method requires 1 argument!";
		return 0;
	}

	#get arguments
	my $mailingListName = shift();

	my $body = <<"EOL";

		$mailingListName

EOL

	return $self->Request('MailingList','Create/MailingList',$body);

}


sub UpdateMailingList
{
	#get object reference
	my $self = shift();

	$self->dprint( "UpdateMailingList called\n");

	#check remaining arguments
	if(@_ != 3) {
		$self->dprint( "UpdateMailingList method requires 3 arguments!\n");
		$self->{result}->{reason} = 'UpdateMailingList method requires 3 arguments!';
		return 0;
	}

	#get arguments
    my $mailingListName = shift();
    my $userName = shift();
	my $listOperation = shift();

	my $body = <<"EOL";
	mailingListName
	$mailingListName

		$userName
		$listOperation

EOL

	return $self->Request('MailingList','Update/MailingList',$body);

}



sub RetrieveMailingList
{
	#get object reference
	my $self = shift();

	$self->dprint( "RetrieveMailingList called\n");

	#check remaining arguments
	if(@_ != 1) {
		$self->dprint( "RetrieveMailingList method requires 1 argument!\n");
		$self->{result}->{reason} = 'RetrieveMailingList method requires 1 arguments!';
		return 0;
	}

	#get argument
    my $mailingListName = shift();

	my $body = <<"EOL";
	mailingListName
	$mailingListName
EOL

	return $self->Request('MailingList','Retrieve/MailingList',$body);
}


sub DeleteMailingList
{
	#get object reference
	my $self = shift();

	$self->dprint( "DeleteMailingList called\n");

	#check remaining arguments
	if(@_ != 1) {
		$self->dprint( "DeleteMailingList method requires 1 argument!\n");
		$self->{result}->{reason} = 'DeleteMailingList method requires 1 argument!';
		return 0;
	}

	#get argument
    my $mailingListName = shift();

	my $body = <<"EOL";
	mailingListName
	$mailingListName
EOL

	return $self->Request('MailingList','Delete/MailingList',$body);
}


################################################################
# below are various subroutines to access local 'private' data #
################################################################

#the content of the request from and reply from Google API engine
sub requestcontent
{
	my $self = shift();

	return $self->{requestcontent};
}

sub replyheaders
{
	my $self = shift();

	return $self->{replyheaders};
}

sub replycontent
{
	my $self = shift();

	return $self->{replycontent};
}


#various access to local variables
sub debug
{
	my $self = shift();

	$self-> { debug } = shift() if (@_);

	return $self->{debug};
}

#change the admin account
sub admin
{
	my $self = shift();

	if (@_)
	{
		$self-> { admin } = shift();
		$self-> { refreshtoken } = 1;
	}

	return $self->{admin};
}

#password can only be set, not read!
sub password
{
	my $self = shift();


	if (@_)
	{
		$self-> { password } = shift();
		#force authentication update on next request
		$self-> { refreshtoken } = 1;
	}

	return '';
}

#the following can only be read!
sub authtime
{
	my $self = shift();

	return $self->{authtime};
}

#same for create time
sub ctime
{
	my $self = shift();

	return $self->{stats}->{ctime};
}

#and request time
sub rtime
{
	my $self = shift();

	return $self->{stats}->{rtime};
}

sub requests
{
	my $self = shift();

	return $self->{stats}->{requests};
}

sub logins
{
	my $self = shift();

	return $self->{stats}->{logins};
}

sub success
{
	my $self = shift();

	return $self->{stats}->{success};
}

sub version
{
	my $self = shift();

	return $APIVersion;
}

#several helper routines

#print out debugging to STDERR if debug is set
sub dprint
{
	my $self = shift();
	my($text) = shift if (@_);
	if( $self->{debug} and defined ($text) ) {
		print STDERR $text . "\n";
	}
}

1;
__END__