File Coverage

blib/lib/JSON/RPC/Common/Marshal/HTTP.pm

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

#!/usr/bin/perl

package JSON::RPC::Common::Marshal::HTTP;
$JSON::RPC::Common::Marshal::HTTP::VERSION = '0.11';
use Moose;
# ABSTRACT: Convert L<HTTP::Request> and L<HTTP::Response> to/from L<JSON::RPC::Common> calls and returns.

use Carp qw(croak);

use Try::Tiny;
use URI::QueryParam;
use MIME::Base64 ();
use HTTP::Response;

use namespace::clean -except => [qw(meta)];

extends qw(JSON::RPC::Common::Marshal::Text);

sub _build_json {
	JSON->new->utf8(1);
}

has prefer_get => (
	isa => "Bool",
	is  => "rw",
	default => 0,
);

has rest_style_methods => (
	isa => "Bool",
	is  => "rw",
	default => 1,
);

has prefer_encoded_get => (
	isa => "Bool",
	is  => "rw",
	default => 1,
);

has expand => (
	isa => "Bool",
	is  => "rw",
	default => 0,
);

has expander => (
	isa => "ClassName|Object",
	lazy_build => 1,
	handles => [qw(expand_hash collapse_hash)],
);

sub _build_expander {
	require CGI::Expand;
	return "CGI::Expand";
}


has user_agent => (
	isa => "Str",
	is  => "rw",
	lazy_build => 1,
);

sub _build_user_agent {
	my $self = shift;
	require JSON::RPC::Common;
	join(" ", ref($self), $JSON::RPC::Common::VERSION),
}

has content_type => (
	isa => "Str",
	is  => "rw",
	predicate => "has_content_type",
);

has content_types => (
	isa => "HashRef[Str]",
	is  => "rw",
	lazy_build => 1,
);

sub _build_content_types {
	return {
		"1.0" => "application/json",
		"1.1" => "application/json",
		"2.0" => "application/json-rpc",
	};
}

has accept_content_type => (
	isa => "Str",
	is  => "rw",
	predicate => "has_accept_content_type",
);

has accept_content_types => (
	isa => "HashRef[Str]",
	is  => "rw",
	lazy_build => 1,
);

sub _build_accept_content_types {
	return {
		"1.0" => "application/json",
		"1.1" => "application/json",
		"2.0" => "application/json-rpc",
	};
}

sub get_content_type {
	my ( $self, $obj ) = @_;

	if ( $self->has_content_type ) {
		return $self->content_type;
	} else {
		return $self->content_types->{ $obj->version || "2.0" };
	}
}

sub get_accept_content_type {
	my ( $self, $obj ) = @_;

	if ( $self->has_accept_content_type ) {
		return $self->accept_content_type;
	} else {
		return $self->accept_content_types->{ $obj->version || "2.0" };
	}
}

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

	$args{prefer_get} = $self->prefer_get unless exists $args{prefer_get};

	if ( $args{prefer_get} ) {
		return $self->call_to_get_request($call, %args);
	} else {
		return $self->call_to_post_request($call, %args);
	}
}

sub call_to_post_request {
	my ( $self, $call, @args ) = @_;

	my $uri = $self->call_reconstruct_uri_base($call, @args);

	my $encoded = $self->call_to_json($call);

	my $headers = HTTP::Headers->new(
		User_Agent     => $self->user_agent,
		Content_Type   => $self->get_content_type($call),
		Accept         => $self->get_accept_content_type($call),
		Content_Length => length($encoded),
	);

	return HTTP::Request->new( POST => $uri, $headers, $encoded );
}

sub call_to_get_request {
	my ( $self, $call, @args ) = @_;

	my $uri = $self->call_to_uri($call, @args);

	my $headers = HTTP::Headers->new(
		User_Agent     => $self->user_agent,
		Accept         => $self->get_accept_content_type($call),
	);

	HTTP::Request->new( GET => $uri, $headers );
}

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

	no warnings 'uninitialized';
	my $prefer_encoded_get = exists $args{encoded}
		? $args{encoded}
		: ( $call->version eq '2.0' || $self->prefer_encoded_get );

	if ( $prefer_encoded_get ) {
		return $self->call_to_encoded_uri($call, %args);
	} else {
		return $self->call_to_query_uri($call, %args);
	}
}

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

	if ( my $base_path = $args{base_path} ) {
		return URI->new($base_path);
	} elsif ( my $uri = $args{uri} ) {
		$uri = $uri->clone;

		if ( my $path_info = $args{path_info} ) {
			my $path = $uri->path;
			$path =~ s/\Q$path_info\E$//;
			$uri->path($path);
		}

		return $uri;
	} else {
	   	URI->new('/');
	}
}

sub call_to_encoded_uri {
	my ( $self, $call, @args ) = @_;

	my $uri = $self->call_reconstruct_uri_base($call, @args);

	my $deflated = $self->deflate_call($call);

	my ( $method, $params, $id ) = delete @{ $deflated }{qw(method params id)};

	my $encoded = $self->encode_base64( $self->encode($params) );

	$uri->query_param( params => $encoded );
	$uri->query_param( method => $method );
	$uri->query_param( id => $id ) if $call->has_id;

	return $uri;
}

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

	my $uri = $self->call_reconstruct_uri_base($call, %args);

	my $deflated = $self->deflate_call( $call );

	my ( $method, $params, $id ) = delete @{ $deflated }{qw(method params id)};

	$params = $self->collapse_query_params($params);

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

	if ( exists $args{rest_style_methods} ? $args{rest_style_methods} : $self->rest_style_methods ) {
		my $path = $uri->path;
		$path =~ s{/?$}{"/" . $method}e; # add method, remove double trailing slash
		$uri->path($path);
	} else {
		$uri->query_param( method => $method );
	}

	return $uri;
}

sub request_to_call {
	my ( $self, $request, @args ) = @_;

	my $req_method = lc( $request->method . "_request_to_call" );

	if ( my $code = $self->can($req_method) ) {
		$self->$code($request, @args);
	} else {
		croak "Unsupported HTTP request method " . $request->method;
	}
}

sub get_request_to_call {
	my ( $self, $request, @args ) = @_;

	$self->uri_to_call(request => $request, @args);
}

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

	my $uri = $args{uri} || ($args{request} || croak "Either 'uri' or 'request' is mandatory")->uri;

	my $params = $uri->query_form_hash;

	if ( exists $params->{params} and $self->prefer_encoded_get ) {
		return $self->encoded_uri_to_call( $uri, %args );
	} else {
		return $self->query_uri_to_call( $uri, %args );
	}
}

sub decode_base64 {
	my ( $self, $base64 ) = @_;
	MIME::Base64::decode_base64($base64);
}

sub encode_base64 {
	my ( $self, $base64 ) = @_;
	MIME::Base64::encode_base64($base64);
}

# the sane way, 1.1-alt
sub encoded_uri_to_call {
	my ( $self, $uri, @args ) = @_;

	my $params = $uri->query_form_hash;

	# the 'params' URI param is encoded as JSON, inflate it
	my %rpc = %$params;

	$rpc{version} ||= "2.0";

	for my $params ( $rpc{params} ) {
		# try as unencoded JSON first
		if ( my $data = try { $self->decode($params) } ) {
			$params = $data;
		} else {
			my $json = $self->decode_base64($params) || croak "params are not Base64 encoded";
			$params = $self->decode($json);
		}
	}

	$self->inflate_call(\%rpc);
}

# the less sane but occasionally useful way, 1.1-wd
sub query_uri_to_call {
	my ( $self, $uri, %args  ) = @_;

	my $params = $uri->query_form_hash;

	my %rpc = ( params => $params );

	foreach my $key (qw(version jsonrpc method id) ) {
		if ( exists $params->{$key} ) {
			$rpc{$key} = delete $params->{$key};
		}
	}

	if ( !exists($rpc{method}) and $args{rest_style_methods} || $self->rest_style_methods ) {
		if ( my $path_info = $args{path_info} ) {
			( $rpc{method} = $path_info ) =~ s{^/}{};
		} elsif ( my $base = $args{base_path} ) {
			my ( $method ) = ( $uri->path =~ m{^\Q$base\E(.*)$} );
			$method =~ s{^/}{};
			$rpc{method} = $method;
		} else {
			my ( $method ) = ( $uri->path =~ m{/(\w+)$} );
			$rpc{method} = $method;
		}
	}

	$rpc{version} ||= "1.1";

	# increases usefulness
	$rpc{params} = $self->expand_query_params($params, %args);

	$self->inflate_call(\%rpc);
}

sub expand_query_params {
	my ( $self, $params, @args ) = @_;

	if ( $self->expand ) {
		return $self->expand_hash($params);
	} else {
		return $params;
	}
}

sub collapse_query_params {
	my ( $self, $params, $request, @args ) = @_;

	if ( $self->expand ) {
		return $self->collapse_hash($params);
	} else {
		return $params;
	}
}

sub post_request_to_call {
	my ( $self, $request ) = @_;
	$self->json_to_call( $request->content );
}

sub write_result_to_response {
	my ( $self, $result, $response, @args ) = @_;

	my %args = $self->result_to_response_params($result);

	foreach my $key ( keys %args ) {
		if ( $response->can($key) ) {
			$response->$key(delete $args{$key});
		}
	}

	if (my @keys = keys %args) {
		croak "Unhandled response params: " . join ' ', @keys;
	}

	return 1;
}

sub response_to_result {
	my ( $self, $response ) = @_;

	if ( $response->is_success ) {
		$self->response_to_result_success($response);
	} else {
		$self->response_to_result_error($response);
	}
}

sub response_to_result_success {
	my ( $self, $response ) = @_;

	$self->json_to_return( $response->content );
}

sub response_to_result_error {
	my ( $self, $response ) = @_;

	my $res = $self->json_to_return( $response->content );

	unless ( $res->has_error ) {
		$res->set_error(
			message => $response->message,
			code    => $response->code, # FIXME dictionary
			data    => {
				response => $response,
			}
		);
	}

	return $res;
}

sub result_to_response {
	my ( $self, $result ) = @_;

	$self->create_http_response( $self->result_to_response_headers($result) );
}

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

	my ( $body, $status ) = delete @args{qw(body status)};

	HTTP::Response->new(
		$status,
		undef,
		HTTP::Headers->new(%args),
		$body,
	);
}

sub result_to_response_headers {
	my ( $self, $result ) = @_;

	my $body = $self->encode($result->deflate);

	return (
		status         => ( $result->has_error ? $result->error->http_status : 200 ),
		Content_Type   => $self->get_content_type($result),
		Content_Length => length($body), # http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html#ResponseHeaders
		body           => $body,
	);
}

sub result_to_response_params {
	my ( $self, $result ) = @_;

	my %headers = $self->result_to_response_headers($result);
	$headers{content_type} = delete $headers{Content_Type};
	$headers{content_length} = delete $headers{Content_Length};

	return %headers;
}

__PACKAGE__->meta->make_immutable();

__PACKAGE__

__END__

=pod

=head1 NAME

JSON::RPC::Common::Marshal::HTTP - Convert L<HTTP::Request> and L<HTTP::Response> to/from L<JSON::RPC::Common> calls and returns.

=head1 VERSION

version 0.11

=head1 SYNOPSIS

	use JSON::RPC::Common::Marshal::HTTP;

	my $m = JSON::RPC::Common::Marshal::HTTP->new;

	my $call = $m->request_to_call($http_request);

	my $res = $call->call($object);

	my $http_response = $m->result_to_response($res);

=head1 DESCRIPTION

This object provides marshalling routines to convert calls and returns to and
from L<HTTP::Request> and L<HTTP::Response> objects.

=head1 ATTRIBUTES

=over 4

=item prefer_get

When encoding a call into a request, prefer GET.

Not reccomended.

=item rest_style_methods

When encoding a GET request, use REST style URI formatting (the method is part
of the path, not a parameter).

=item prefer_encoded_get

When set and a C<params> param exists, decode it as Base 64 encoded JSON and
use that as the parameters instead of the query parameters.

See L<http://json-rpc.googlegroups.com/web/json-rpc-over-http.html>.

=item user_agent

Defaults to the marshal object's class name and the L<JSON::RPC::Common>
version number.

=item content_type

=item accept_content_type

=item content_types

=item accept_content_types

When explicitly set these are the values of the C<Content-Type> and C<Accept>
headers to set.

Otherwise they will default to C<application/json> with calls/returns version
1.0 and 1.1, and C<application/json-rpc> with 2.0 objects.

=item expand

Whether or not to use an expander on C<GET> style calls.

=item expander

An instance of L<CGI::Expand> or a look alike to use for C<GET> parameter
expansion.

=back

=head1 METHODS

=over 4

=item request_to_call $http_request

=item post_request_to_call $http_request

=item get_request_to_call $http_request

Convert an L<HTTP::Request> to a L<JSON::RPC::Common::Procedure::Call>.
Depending on what style of request it is, C<request_to_call> will delegate to a
variant method.

Get requests call C<uri_to_call>

=item uri_to_call $uri

=item encoded_uri_to_call $uri

=item query_uri_to_call $uri

Parse a call from a GET request's URI.

=item result_to_response $return

Convert a L<JSON::RPC::Common::Procedure::Return> to an L<HTTP::Response>.

=item write_result_to_response $result, $response

Write the result into an object like L<Catalyst::Response>.

=item response_to_result $http_response

=item response_to_result_success $http_response

=item response_to_result_error $http_response

Convert an L<HTTP::Response> to a L<JSON::RPC::Common::Procedure::Return>.

A variant is chosen based on C<HTTP::Response/is_success>.

The error handler will ensure that
L<JSON::RPC::Common::Procedure::Return/error> is set.

=item call_to_request $call, %args

=item call_to_get_request $call, %args

=item call_to_post_request $call, %args

=item call_to_uri $call, %args

=item call_to_encoded_uri $call, %args

=item call_to_query_uri $call, %args

Convert a call to a request (or just a URI for GET requests).

The arguments can contain a C<uri> parameter, which is the base of the request.

With GET requests, under C<rest_style_methods> that URI's path will be
appended, and otherwise parameters will just be added.

POST requests do not cloen and alter the URI.

If no URI is provided as an argument, C</> will be used.

The flags C<prefer_get> and C<encoded> can also be passed to
C<call_to_request> to alter the type of request to be generated.

=item collapse_query_params

=item expand_query_params

Only used for query encoded GET requests. If C<expand> is set will cause
expansion of the params. Otherwise it's a noop.

Subclass and override to process query params into RPC params as necessary.

Note that this is B<NOT> in any of the JSON-RPC specs.

=back

=head1 AUTHOR

Yuval Kogman <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2014 by Yuval Kogman and others.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut