WWW::Metaweb - An interface to the Metaweb database via MQL

  use strict;
  use WWW::Metaweb;

  my $mh = WWW::Metaweb->connect( username => $u,
				  password => $p, 
				  server => 'www.freebase.com',
				  auth_uri => '/api/account/login',
				  read_uri => '/api/service/mqlread',
				  write_uri => '/api/service/mqlwrite',
				  trans_uri => '/api/trans',
				  pretty_json => 1 );

  my $query = {
	  '/type/object/creator' => undef,
	  cover_appearances => [{
	    type => '/comic_books/comic_book_issue',
	    name => undef,
	    part_of_series => undef
	  }],
	  created_by => [],
	  id => undef,
	  name => 'Nico Minoru',
	  type => '/comic_books/comic_book_character'
  };

  my $result = $mh->read($query, 'json');
  print $result;

  $mh->add_query('read', $query);
  $mh->send_envelope('read')
    or die $WWW::Metaweb::errstr;

  my $result = $mh->result('read', 'json');
  print $result . "\n";

package WWW::Metaweb;

use 5.008006;
use strict;
use warnings;

use JSON::XS;
use LWP::UserAgent;
use URI::Escape;
use HTTP::Request;
use Carp;

# debugging
use Data::Dumper;

our $VERSION = '0.02';
our $errstr = '';

sub version  {
	return $WWW::Metaweb::VERSION;
} # ->version

sub connect  {
	my $invocant = shift;
	my $class = ref($invocant) || $invocant;
	my ($username, $password);


	my $options = { @_ };
	$username = $options->{username} || '' if exists $options->{username};
	$password = $options->{password} || '' if exists $options->{password};
	delete $options->{username};
	delete $options->{password};

	my $self = {
		     auth_uri => undef,
		     read_uri => undef,
		     write_uri => undef,
		     trans_uri => undef,
		     read_envelope => { },
		     write_envelope => { },
		     result_envelope => { },
		     json_preprocessor => undef,
		     pretty_json => 0,
		     query_counter => 0,
		     debug => 0
		   };
	
	bless $self, $class;
	
	$self->server($options->{server}); # Sets the server.
	delete $options->{server};
	# Sets the option attributes from $options into $self.
	foreach my $key (keys %$options)  {
		if (exists $self->{$key})  {
			$self->{$key} = $options->{$key};
		}
		else  {
			carp "Unknown option '$key' used in connect().";
		}
	}

	# A little bit of vanity here (the agent).
	$self->useragent(LWP::UserAgent->new( agent => 'Metaweb/'.$WWW::Metaweb::VERSION,
					      timeout => 10)
			);

	# Attempt to authenticate if $username and $password are defined.
	# As far as Freebase goes this is a required step right now.
	if (defined $username && defined $password)  {
		$self = undef unless ($self->authenticate($username, $password));
	}

	return $self;
} # ->connect

sub authenticate  {
	my $self = shift;
	my ($username, $password) = @_;
	my ($response, $raw_header, $credentials, @cookies);
	my $login_url = $self->server.$self->{auth_uri};


	$response = $self->useragent->post($login_url, { username => $username,
						       	 password => $password
						       });
	# This would indicate some form of network problem (such as the server
	# being down).
	unless ($response->is_success)  {
		$WWW::Metaweb::errstr = 'Authentication HTTP request failed: ' . $response->status_line;
		return undef;
	}

	unless ($raw_header = $response->header('Set_Cookie'))  {
		# Authentication failed.
		my $jsonxs = JSON::XS->new->utf8;
		my $reply = $jsonxs->decode($response->content);
		$WWW::Metaweb::errstr = "Login failed: [status: $reply->{status}, code: $reply->{code}]";
		
		return undef;
	}
	@cookies = split /,\s+/, $raw_header;
	$credentials = '';
	my $crumb_count = 0;
	foreach my $cookie (@cookies)  {
		my @crumbs = split ';', $cookie;
		$credentials .= ';';
		$credentials .= $crumbs[0];
	}

	$self->useragent->default_header('Cookie' => $credentials);
	$self->{authenticated} = 1;

	return 1;
} # ->authenticate

sub read  {
	my $self = shift;
	my @read_queries = @_;
	my ($i, $format);

	$self->clear_read_queries;
	
	# Add each query to the envelope and replace it's place in the array
	# with the query name asigned to it.
	for ($i = 0; $i < @read_queries; $i++)  {
		if ($read_queries[$i] eq 'perl' || $read_queries[$i] eq 'json')  {
			$format = $read_queries[$i];
			delete $read_queries[$i];
		}
		else  {
			my $read_query = $read_queries[$i];
			$read_queries[$i] = "query$i";

			$self->add_read_query($read_queries[$i] => $read_query);
			#carp 'WWW::Metaweb - Bad format in read() - ($format = \'' . $read_queries[$i] . '\')';
			#delete $read_queries[$i];
		}
	}

	# We're helpless if this fails, return undef and trust the errstr has
	# been set further down.
	return undef unless (defined $self->send_read_envelope);

	# Replace the query names in our array with the result of the query.
	map { $_ = $self->result($_, $format); } @read_queries;

	# If there is only one result and an array hasn't been asked for, return
	# the single value as a scaler instead.
	return (@read_queries == 1 && not wantarray) ? $read_queries[0] : @read_queries;
} # ->read

sub write  {
	my $self = shift;
	my @write_queries = @_;
	my ($i, $format);

	# This method works exactly the same as the read method.
	
	$self->clear_write_queries;
	
	for ($i = 0; $i < @write_queries; $i++)  {
		if ($write_queries[$i] eq 'perl' || $write_queries[$i] eq 'json')  {
			$format = $write_queries[$i];
			delete $write_queries[$i];
		}
		else  {
			my $write_query = $write_queries[$i];
			$write_queries[$i] = "query$i";

			$self->add_write_query($write_queries[$i] => $write_query);
		}

	}

	return undef unless defined $self->send_write_envelope;

	map { $_ = $self->result($_, $format); } @write_queries;

	return (@write_queries == 1 && not wantarray) ? $write_queries[0] : @write_queries;
} # ->write

sub trans  {
	my $self = shift;
	my $translation = shift;
	my $guid = lc shift;
	my ($url, $response);

	# Check that the guid looks mostly correct and replace a hash at the
	# beginning of the guid with the URI escape code.
	unless ($guid =~ s/^(\#|\%23)([\da-f]+)$/\%23$2/)  {
		$WWW::Metaweb::errstr = "Bad guid: $guid";
		return undef;
	}

	$url = $self->server.$self->{trans_uri}.'/'.$translation.'/'.$guid;
	$response = $self->useragent->get($url);
	
	# An HTTP response that isn't success indicates something bad has
	# happened and there's nothing I can do about it.
	unless ($response->is_success)  {
		$WWW::Metaweb::errstr = "Trans query failed, HTTP response: " . $response->status_line;
		return undef;
	}

	return $response->content;
} # ->trans

sub raw  {
	my $self = shift;
	my $guid = shift;

	return $self->trans('raw', $guid);
} # ->raw

sub image_thumb  {
	my $self = shift;
	my $guid = shift;

	return $self->trans('image_thumb', $guid);
} # ->image_thumb

sub blurb  {
	my $self = shift;
	my $guid = shift;

	return $self->trans('blurb', $guid);
} # ->blurb

sub add_query  {
	my $self = shift;
	my $method = shift;
	my ($envelope, $queries);

	return undef unless $envelope = __test_envelope($method, 'add_query');

	if (@_ == 1)  {
		my $query = shift;
		$queries = { netmetawebquery => $query };
	}
	elsif (@_ > 1 && (@_ % 2) == 0)  {
		$queries = { @_ };
	}
	else  {
		$WWW::Metaweb::errstr = "Query name found with missing paired query. You probably have an odd number of query names and queries.";
		return undef;
	}

	my ($query_name, $query);
	my $no_error = 1;	
	foreach $query_name (keys %$queries)  {
		$query = $queries->{$query_name};
		$no_error = 0 unless $self->check_query_syntax($method, $queries->{$query_name});

		if (ref $query eq 'HASH' or ref $query eq 'ARRAY')  {
			# It's a Perl structure.
			if (((ref $query) eq 'HASH' && (not defined $query->{query})) || ((ref $query) eq 'ARRAY' && (not defined $query->[0]->{query})))  {
				$query = { query => $query };
			}
			$query->{anti_cache} = (time . $self->{query_counter}++);
			$query->{cursor} = JSON::XS::true if $self->{auto_cursors} && not defined $query->{cursor};
		}
		elsif ((not ref $query))  {
			# It's a JSON string - but we'll convert it to Perl and
			# back again to manipulate it.
			my ($jxs, $p_query);
			$p_query = from_json($query);
			if (((ref $p_query) eq 'HASH' && (not defined $p_query->{query})) || ((ref $p_query eq 'ARRAY') && (not defined $p_query->[0]->{query})))  {	
				$p_query = { query => $p_query };
			}
			$p_query->{anti_cache} = (time . $self->{query_counter}++);
			$p_query->{cursor} = JSON::XS::true if $self->{auto_cursors} && not defined $query->{cursor};
			$query = to_json($p_query);
		}
		# Now store it for sending.
		$self->{$envelope}->{$query_name} = $query;
	}

	return $no_error;
} # ->add_query

sub clear_queries  {
	my $self = shift;
	my $method = shift;
	my $envelope;

	return undef unless $envelope = __test_envelope($method, 'clear_envelope');

	$self->{$envelope} = { };

	return 1;
} # ->clear_queries

sub query_count  {
	my $self = shift;
	my $method = shift;
	my ($envelope, @keys, $key_count);

	return undef unless $envelope = __test_envelope($method, 'query_count');
	@keys = keys %{$self->{$envelope}};
	$key_count = @keys;
	
	return $key_count; 
} # ->query_count

sub check_query_syntax  {
	my $self = shift;
	my $method = shift;
	my $query = shift;

	return 1;
} # ->check_query_syntax

sub send_envelope  {
	my $self = shift;
	my $method = shift;
	my $envelope;

	return undef unless $envelope = __test_envelope($method, 'send_envelope');

	my $jsonxs = JSON::XS->new->utf8;
	my ($json_envelope, $url, $request, $response);

	# Create a list of pre-processors
	my @preprocessors;
	if (ref $self->{json_preprocessor} eq 'CODE')  {
		@preprocessors = ( $self->{json_preprocessor} );
	}
	elsif (ref $self->{json_preprocessor} eq 'ARRAY')  {
		foreach my $sub (@{$self->{json_preprocessor}})  {
			push @preprocessors, $sub if (ref $sub eq 'CODE');
		}
	}
	
	my $first = 1;
	$json_envelope = '{';
	foreach my $query_name (keys %{$self->{$envelope}})  {
		my $query = (ref $self->{$envelope}->{$query_name}) ? $jsonxs->encode($self->{$envelope}->{$query_name}) : $self->{$envelope}->{$query_name};
		#$query =~ s/"format":"(?:json|perl)",//;

		foreach my $sub (@preprocessors)  {
			$query = &$sub($query);
		}
		# If the query has been botched - set it to an empty string.
		$query = '' unless defined $query;

		$json_envelope .= ',' if $first == 0;
		$json_envelope .= '"'.$query_name.'":'.$query;

		$first = 0;
	}
	$json_envelope .= '}';

	print $json_envelope . "\n" if $self->{debug};
	
	# Set up the request depending on whether this is a read or write op.
	$request = HTTP::Request->new;
	$request->header( 'X-Metaweb-Request' => 'True' );
	if ($method eq 'read')  {
		$request->method('GET');
		$request->uri($self->server.$self->{$method.'_uri'}.'?queries='.uri_escape($json_envelope));
	}
	else  {
		$request->method('POST');
		$request->uri($self->server.$self->{$method.'_uri'});
		$request->content_type('application/x-www-form-urlencoded'); 
		$request->content('queries='.uri_escape($json_envelope));
	}
	$response = $self->useragent->request($request);

	$self->{last_envelope_sent} = $method;

	unless ($response->is_success)  {
		$WWW::Metaweb::errstr = "Query failed, HTTP response: " . $response->status_line;
		return undef;
	}
	
	return ($self->set_result($method, $response->content)) ? $response->is_success : undef;
} # ->send_envelope

sub add_read_query  {
	my $self = shift;

	return $self->add_query('read', @_);
} # ->add_read_query

sub add_write_query  {
	my $self = shift;

	return $self->add_query('write', @_);
} # ->add_write_query

sub clear_read_queries  {
	my $self = shift;

	return $self->clear_queries('read', @_);
} # ->clear_read_queries

sub clear_write_queries  {
	my $self = shift;

	return $self->clear_queries('write', @_);
} # ->clear_write_queries

sub read_query_count  {
	my $self = shift;

	return $self->query_count('read', @_);
} # ->read_query_count

sub write_query_count  {
	my $self = shift;

	return $self->query_count('write', @_);
} # ->write_query_count

sub send_read_envelope  {
	my $self = shift;

	return $self->send_envelope('read');
} # ->send_read_envelope

sub send_write_envelope  {
	my $self = shift;

	return $self->send_envelope('write');
} # ->send_write_envelope

sub set_result  {
	my $self = shift;
	my $method = shift;
	my $json_result = shift;
	my $envelope;

	return undef unless $envelope = __test_envelope($method, 'set_result');
	
	$self->{result_envelope} = $json_result;
	my $perl_result = from_json($json_result);

	my $status = $perl_result->{status};
	unless ($status eq '200 OK')  {
		$WWW::Metaweb::errstr = 'Bad outer envelope status: ' . $status;
		return 0;
	}

	$self->{result_format} = { };
	foreach my $query_name (keys %{$self->{$envelope}})  {
		$self->{result_format}->{$query_name} = (ref $self->{$envelope}->{$query_name}) ? 'perl' : 'json';
	}

	return 1;
} # ->set_result

sub result_is_ok  {
	my $self = shift;
	my $query_name = shift || 'netmetawebquery';
	my $result_is_ok = undef;

	my $result = from_json($self->{result_envelope})->{$query_name};	
	if (defined $result)  {
		my ($code, $message);
		$code = $result->{code};
		if ($code eq '/api/status/ok')  {
			$result_is_ok = 1;
		}
		else  {
			$message = $result->{messages}->[0]->{message};
			$WWW::Metaweb::errstr = "Result status not okay for $query_name: $code; error: $message;";
		}

	}
	else  {
		$WWW::Metaweb::errstr = 'No result found for query name: ' . $query_name;
		$result_is_ok = undef;
	}
	
	return $result_is_ok;
} # ->result_is_okay

sub result  {
	my $self = shift;
	my $query_name = shift || 'netmetawebquery';
	my $format = shift;
	my $result;
	my $raw_result;
	my $perl_result;

	# If the query isn't okay - just return undef, errstr will have been set
	return undef unless $self->result_is_ok($query_name);

	# Check the return format if it hasn't been explicitly set.
	$format = $self->{result_format}->{$query_name} unless defined $format;
	
	$JSON::UnMapping = 1;
	$perl_result = from_json($self->{result_envelope})->{$query_name}->{result};

	if ($format eq 'json')  {
		$result = JSON::XS->new->utf8->pretty($self->{pretty_json})->encode($perl_result);
	}
	else  {
		$result = $perl_result;
	}
	
	return $result;
} # ->result

sub raw_result  {
	my $self = shift;

	return $self->{result_envelope} || '';
} # ->raw_result

sub useragent  {
	my $self = shift;
	my $new_useragent = shift;

	$self->{ua} = $new_useragent if defined $new_useragent;

	return $self->{ua};
} # ->useragent

sub server  {
	my $self = shift;
	my $new_server = shift;
	
	$self->{server} = $new_server if defined $new_server;
	$self->{server} = 'http://'.$self->{server} unless $self->{server} =~ /^http:\/\//;

	return $self->{server};
} # ->server

################################################################################
# Below here are private functions - so no POD for here.

# __test_envelope
# Tests that an envelope is either 'read' or 'write'. If it is, '_envelope' is
# appended and returned. If not, undef is returned and an error message is set.
sub __test_envelope  {
	my $envelope = shift;
	my $method = shift;

	if ($envelope eq 'read' || $envelope eq 'write')  {
		$envelope .= '_envelope';
	}
	else  {
		$WWW::Metaweb::errstr = "Envelope must have a value of 'read' or 'write' in $method()";
		$envelope = undef;
	}

	return $envelope;
} # &__test_envelope

return 1;
__END__