lib/Dancer/Plugin/Tapir.pm

package Dancer::Plugin::Tapir;

=head1 NAME

Dancer::Plugin::Tapir - Associate a Tapir handler with Dancer routes

=head1 SYNOPSIS

  use Dancer;
  use Dancer::Plugin::Tapir;

  setup_thrift_handler
    thrift_idl    => 'thrift/service.thrift',
    handler_class => 'MyAPI::Service';

=head1 DESCRIPTION

The goal of this package is to quickly and without fuss expose a L<Tapir> service via L<Dancer> via a RESTful API.  Doing so requires no additional coding, and only requires a simple comment added to your Thrift methods.

This plugin exports the method C<setup_thrift_handler> into the caller.  Call it with either a list of arguments or using your Dancer configuration (see below).

The handler class must be a subclass of L<Tapir::Server::Handler::Class> and have registered methods for each Thrift method of the Thrift service.

The Dancer routes that will be exposed match up with the C<@rest> Thrift documentation tag.  For example:

  /*
    Create a new account
    @rest POST /accounts
  */
  account createAccount (
    1: username username,
    2: string   password
  )

This will create a route C<POST /accounts> which will call the method C<createAccount> in the handler class.  The Dancer method C<params> will be used to extract both query string and payload parameters, and will be used to compose the thrift message passed to the L<Tapir::Server::Handler>.

Control over the HTTP status code returned to the user is still being worked out, as are being able to set headers in the HTTP response.  At the moment, the result is serialized via JSON but will in the future be serialized according to the Accept headers of the request.

=head1 CONFIGURATION

Add something like this to your YAML config:

  plugins:
    Tapir:
      thrift_idl: thrift/service.thrift
      handler_class: MyAPI::Service

=cut

use Dancer ':syntax';
use Dancer::Plugin;
use Carp;
use Try::Tiny;
use Capture::Tiny qw(capture);
use JSON::XS qw();
use Scalar::Util qw(blessed);

# POE sessions will be created by Tapir::MethodCall; let's not see an error about POE never running
use POE;
POE::Kernel->run();

use Thrift::IDL;
use Thrift::Parser;
use Tapir::Validator;
use Tapir::MethodCall;

my $json_xs = JSON::XS->new->allow_nonref->allow_blessed;

our $VERSION = 0.03;

register setup_thrift_handler => sub {
	my ($self, @args) = plugin_args(@_);
	# $self is undef for Dancer 1
	my $conf = plugin_setting();
	my %conf = ( %$conf, @args );

	## Validate the plugin settings

	if (my @missing_args = grep { ! defined $conf{$_} } qw(thrift_idl handler_class)) {
		croak "Missing configuration settings for Tapir plugin: " . join('; ', @missing_args);
	}
	if (! -f $conf{thrift_idl}) {
		croak "Invalid thrift_idl file '$conf{thrift_idl}'";
	}
	
	## Audit the IDL

	my $idl = Thrift::IDL->parse_thrift_file($conf{thrift_idl});

	# Conduct an audit of the thrift document to ensure that all the methods are
	# documented, have a @rest declaration, and all custom types are defined before
	# being used.  Further, this will fill in the $object->{doc} hash for each
	# Thrfit::IDL object, which is necessary for validate_parser_message as well as
	# extracting the @rest values later.

	my $validator = Tapir::Validator->new(
		audit_types => 1,
		docs => {
			require => {
				methods => 1,
				rest    => 1,
			},
		},
	);
	if (my @errors = $validator->audit_idl_document($idl)) {
		croak "Invalid thrift_idl file '$conf{thrift_idl}'; the following errors were found:\n"
			. join("\n", map { " - $_" } @errors);
	}

	my %services = map { $_->name => $_ } @{ $idl->services };

	## Use the handler class and test for completeness

	my $handler_class = $conf{handler_class};
	eval "require $handler_class";
	if ($@) {
		croak "Failed to load $handler_class: $@";
	}
	if (! $handler_class->isa('Tapir::Server::Handler::Class')) {
		croak "$handler_class must be a subclass of Tapir::Server::Handler::Class";
	}

	if (! $handler_class->service) {
		croak "$handler_class didn't call service()";
	}
	my $service = $services{ $handler_class->service };
	if (! $service) {
		croak "$handler_class is for the service ".$handler_class->service.", which is not registered with $conf{thrift_idl}";
	}

	my %methods = map { $_->name => $_ } @{ $service->methods };
	my %handled_methods = %{ $handler_class->methods };
	foreach my $method_name (keys %methods) {
		if (! $handled_methods{$method_name}) {
			croak "$handler_class doesn't handle method $methods{$method_name}";
		}
	}

	## Setup custom namespaced Thrift classes
	
	my $parser = Thrift::Parser->new(idl => $idl, service => $service->name);

	## Setup routes
	
	my $logger = Dancer::LoggerMockObject->new();

	while (my ($method_name, $method_idl) = each %methods) {
		my ($http_method, $dancer_route) = @{ $method_idl->{doc}{rest} }{'method', 'route'};
		my $dancer_method = 'Dancer::' . $http_method;

		my $method_message_class = $parser->{methods}{$method_name}{class};

		my $dancer_sub = sub {

		## Create a method call from the Dancer request

			my $request = request;
			my $params = $request->params;

			# Decode the JSON payload
			if ($request->content_length && $request->content_type && $request->content_type eq 'application/json' && length $request->body) {
				my $body = try {
					$json_xs->decode($request->body)
				}
				catch {
					print STDERR "JSON payload was:\n" . $request->body . "\n";
					die "Error in decoding the JSON payload (length " . $request->content_length . "): $_";
				};
				die unless $body && ref $body && ref $body eq 'HASH';
				$params->{$_} = $body->{$_} foreach keys %$body;
			}

			my $thrift_message;
			try {
				$thrift_message = $method_message_class->compose_message_call(%$params);
			}
			catch {
				my $ex = $_;
				if (ref $ex && blessed $ex && $ex->isa('Exception::Class::Base')) {
					if ($ex->isa('Thrift::Parser::InvalidArgument')) {
						$ex->rethrow();
					}
				}
				die "Error in composing $method_message_class message: $_\n";
			};

			$validator->validate_parser_message($thrift_message);

			my $call = Tapir::MethodCall->new(
				service   => $service,
				message   => $thrift_message,
				transport => $request,
				logger    => $logger,
			);

		## Pass call to handler class and inspect result

			# Ask the handler class to add one or more action to the call object
			$handler_class->add_call_actions($call);

			# We can't check is_finished since that's only set via a POE post; check instead to see
			# if the action called set_result, set_exception or set_error
			my $call_is_finished_sub = sub {
				my @set = grep { $call->heap_isset($_) } qw(result exception error);
				return $set[0];
			};

			my $run_call_actions_sub = sub {
				# Execute the actions until one of them calls set_result, set_exception or set_error
				while (my $action = $call->get_next_action) {
					$action->($call);
					last if $call_is_finished_sub->();
				}
			};

			# Wrap the call in a Capture::Tiny so that we can send STDOUT and STDERR to Dancer
			my ($stdout, $stderr) = capture { $run_call_actions_sub->() };
			foreach ([ info => $stdout ], [ error => $stderr ]) {
				my ($level, $string) = @$_;
				next unless $string;
				foreach my $line (split /\n/, $string) {
					$logger->$level($handler_class.' in handling '.$call->method->name.' emitted: '.$line);
				}
			}

			# Figure out if the handler set result, error or exception and fetch the value
			my $result_key = $call_is_finished_sub->();
			if (! $result_key) {
				die $handler_class.' in handling '.$call->method->name." never called set_result, set_exception or set_error\n";
			}
			my $result_value = $call->heap_index($result_key);

			# The handler can communicate with us via 'rest_result' in the heap.  If set, use this to send
			# extra headers or override our default status code
			my $status;
			if (my $extra_actions = $call->heap_index('rest_result')) {
				if (my $code = $extra_actions->{status_code}) {
					$status = $code;
				}
				if (my $headers = $extra_actions->{headers}) {
					headers %$headers;
				}
			}

		## Setup the response and return

			# The handler set result.  Validate the result value against the Thrift specification, and return
			# it encoded in JSON.
			my $response;
			if ($result_key eq 'result') {
				try {
					# Compose a reply to the method using the result value.  This will throw if any values are 
					# missing or not valid for the specification.  This returns a Thrift::Parser::Message which
					# contains the reply as a field set keyed on 'return_value'.  Let's turn that into JSON.
					my $thrift_reply = $thrift_message->compose_reply($result_value);
					$response = Tapir::MethodCall::dereference_fieldset($thrift_reply->arguments, { plain => 1 });
					$response = $json_xs->encode($response->{return_value});
				}
				catch {
					die "Error in composing $method_message_class result: $_\n";
				};
				$status ||= 200;
			}
			# The handler set either 'error' or 'exception'; return a status 500 with a JSON payload describing the problem
			else {
				$status ||= 500;
				$response = $json_xs->encode({ $result_key => $result_value });
			}

			header 'content-type' => 'application/json';
			status $status;
			return $response;
		};

		my $wrapper_sub = sub {
			my $result;
			try {
				$result = $dancer_sub->(@_);
			}
			catch {
				my $ex = $_;
				my $status = 'error';
				if (ref $ex && blessed $ex && $ex->isa('Exception::Class::Base')) {
					my $string_error;
					if ($ex->isa('Tapir::InvalidArgument') || $ex->isa('Thrift::Parser::InvalidArgument')) {
						$status = 400;
						if ($ex->key && $ex->value) {
							$string_error = sprintf "The argument '%s' ('%s') was invalid: %s", $ex->key, $ex->value, $ex->error;
						}
						elsif ($ex->key) {
							$string_error = sprintf "The argument '%s' was invalid: %s", $ex->key, $ex->error;
						}
						else {
							$string_error = sprintf "There was an invalid argument: %s", $ex->error;
						}
					}
					else {
						# Look for a stack trace frame that is not Thrift::Parser so we can see
						# any thrift-related errors from the perspective of the caller
						my ($trace_frame, $first_frame);
						while (my $frame = $ex->trace->next_frame) {
							$first_frame ||= $frame;
							next if $frame->package =~ m{^Thrift};
							$trace_frame = $frame;
							last;
						}
						$trace_frame ||= $first_frame;

						$string_error = $ex->error . " in " . $trace_frame->as_string;
					}
					$logger->error($string_error);
					$result = $json_xs->encode({
						error => $string_error,
					});
				}
				else {
					$logger->error("$ex");
					$result = $json_xs->encode({ exception => "$ex" });
				}
				header 'content-type' => 'application/json';
				status $status;
			};

			# Returning the result will print it to the HTTP response
			return $result;
		};

		# Install the route
		{
			no strict 'refs';
			$dancer_method->($dancer_route => $wrapper_sub);
		}
	}
};

register_plugin;

{
	package Dancer::LoggerMockObject;

	use strict;
	use warnings;

	sub new {
		my $class = shift;
		return bless {}, $class;
	}

	sub core    { shift; Dancer::Logger::core(@_); }
	sub debug   { shift; Dancer::Logger::debug(@_); }
	sub warning { shift; Dancer::Logger::warning(@_); }
	sub error   { shift; Dancer::Logger::error(@_); }
	sub info    { shift; Dancer::Logger::info(@_); }
}

=head1 SEE ALSO

L<Tapir>, L<Dancer>

=head1 COPYRIGHT

Copyright (c) 2012 Eric Waters.  All rights reserved.  This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=head1 AUTHOR

Eric Waters <ewaters@gmail.com>

=cut

true;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)