File Coverage

blib/lib/Mojolicious/Plugin/XRD.pm

Criterion	Covered	Total	%
statement	37	91	40.6
branch	10	66	15.1
condition	9	30	30.0
subroutine	6	8	75.0
pod	1	1	100.0
total	63	196	32.1

package Mojolicious::Plugin::XRD;
use Mojo::Base 'Mojolicious::Plugin';
use Mojo::Util qw/quote deprecated/;

our $VERSION = '0.22';

# Todo: Support
#  $self->reply->xrd( $xrd => {
#    resource => 'acct:[e-mail]',
#    expires  => (30 * 24 * 60 * 60),
#    cache    => ...,
#    chi      => ...
#  });
#
# - Add Acceptance for XRD and JRD and JSON as a header

# UserAgent name
my $UA_NAME = __PACKAGE__ . ' v' . $VERSION;

# UserAgent maximum redirects
my $UA_MAX_REDIRECTS   = 10;

# UserAgent connect timeout
my $UA_CONNECT_TIMEOUT = 7;


# Register Plugin
sub register {
  my ($plugin, $mojo) = @_;

  # Add types
  for ($mojo->types) {
    $_->type(jrd => 'application/jrd+json');
    $_->type(xrd => 'application/xrd+xml');
  };

  my $reply_xrd = sub {
    my ($c, $xrd, $res) = @_;

    # Define xrd or jrd
    unless ($c->stash('format')) {
      $c->stash('format' => scalar $c->param('format'));
    };

    # Add CORS header
    $c->res->headers->header(
      'Access-Control-Allow-Origin' => '*'
    );

    my $status = 200;

    # Not found
    if (!defined $xrd || !ref($xrd)) {
      $status = 404;
      $xrd = $c->helpers->new_xrd;
      $xrd->subject("$res") if $res;
    }

    # rel parameter
    elsif ($c->param('rel')) {

      # Clone and filter relations
      $xrd = $xrd->filter_rel( $c->every_param('rel') );
    };

    my $head_data = $c->req->method eq 'HEAD' ? '' : undef;

    # content negotiation
    return $c->respond_to(

      # JSON request
      json => sub { $c->render(
        status => $status,
        data   => $head_data // $xrd->to_json,
        format => 'json'
      )},

      # JRD request
      jrd => sub { $c->render(
        status => $status,
        data   => $head_data // $xrd->to_json,
        format => 'jrd'
      )},

      # XML default
      any => sub { $c->render(
        status => $status,
        data   => $head_data // $xrd->to_pretty_xml,
        format => 'xrd'
      )}
    );
  };

  # Add DEPRECATED 'render_xrd' helper
  $mojo->helper(
    render_xrd => sub {
      deprecated 'render_xrd is deprecated in favor of reply->xrd';
      $reply_xrd->(@_)
    }
  );

  # Add 'reply->xrd' helper
  $mojo->helper( 'reply.xrd' => $reply_xrd);

  # Add 'get_xrd' helper
  $mojo->helper( get_xrd => \&_get_xrd );

  # Add 'new_xrd' helper
  unless (exists $mojo->renderer->helpers->{'new_xrd'}) {
    $mojo->plugin('XML::Loy' => {
      new_xrd => [-XRD]
    });
  };
};

# Get XRD document
sub _get_xrd {
  my $c = shift;
  my $resource = Mojo::URL->new( shift );

  # Trim tail
  pop while @_ && !defined $_[-1];

  # No valid resource
  return unless $resource->host;

  my $header = {};
  if ($_[0] && ref $_[0] && ref $_[0] eq 'HASH') {
    $header = shift;
  };

  # Check if security is forced
  my $prot = $resource->protocol;
  my $secure;
  $secure = 1 if $prot && $prot eq 'https';

  # Get callback
  my $cb = pop if ref($_[-1]) && ref($_[-1]) eq 'CODE';

  # Build relations parameter
  my $rel;
  $rel = shift if $_[0] && ref $_[0] eq 'ARRAY';

  # Get secure user agent
  my $ua = Mojo::UserAgent->new(
    name => $UA_NAME,
    max_redirects => ($secure ? 0 : $UA_MAX_REDIRECTS),
    connect_timeout => $UA_CONNECT_TIMEOUT
  );

  my $xrd;

  # Set to secure, if not defined
  $resource->scheme('https') unless $resource->scheme;

  # Get helpers proxy object
  my $h = $c->helpers;

  # Is blocking
  unless ($cb) {

    # Fetch Host-Meta XRD - first try ssl
    my $tx = $ua->get($resource => $header);
    my $xrd_res;

    # Transaction was not successful
    return unless $xrd_res = $tx->success;

    unless ($xrd_res->is_success) {

      # Only support secure retrieval
      return if $secure;

      # Was already insecure
      return if $resource->protocol eq 'http';

      # Make request insecure
      $resource->scheme('http');

      # Update insecure max_redirects;
      $ua->max_redirects($UA_MAX_REDIRECTS);

      # Then try insecure
      $tx = $ua->get($resource => $header);

      # Transaction was not successful
      return unless $xrd_res = $tx->success;

      # Retrieval was successful
      return unless $xrd_res->is_success;
    };

    # Parse xrd document
    $xrd = $h->new_xrd($xrd_res->body) or return;

    # Filter relations
    $xrd = $xrd->filter_rel($rel) if $rel;

    # Return xrd
    return ($xrd, $xrd_res->headers->clone) if wantarray;
    return $xrd;
  };

  # Non-blocking
  # Create delay for https with or without redirection
  my $delay = Mojo::IOLoop->delay(
    sub {
      my $delay = shift;

      # Get with https - possibly without redirects
      $ua->get($resource => $header => $delay->begin);
    },
    sub {
      my ($delay, $tx) = @_;

      # Get response
      if (my $xrd_res = $tx->success) {

        # Fine
        if ($xrd_res->is_success) {

          # Parse xrd document
          $xrd = $h->new_xrd($xrd_res->body) or return $cb->(undef);

          # Filter relations
          $xrd = $xrd->filter_rel($rel) if $rel;

          # Send to callback
          return $cb->($xrd, $xrd_res->headers->clone);
        };

        # Only support secure retrieval
        return $cb->(undef) if $secure;
      }

      # Fail
      else {
        return $cb->(undef);
      };

      # Was already insecure
      return if $resource->protocol eq 'http';

      # Try http with redirects
      $delay->steps(
        sub {
          my $delay = shift;

          $resource->scheme('http');

          # Get with http and redirects
          $ua->max_redirects($UA_MAX_REDIRECTS);
          $ua->get($resource => $header => $delay->begin );
        },
        sub {
          my $delay = shift;

          # Transaction was successful
          if (my $xrd_res = pop->success) {

            # Parse xrd document
            $xrd = $h->new_xrd($xrd_res->body) or return $cb->(undef);

            # Filter relations
            $xrd = $xrd->filter_rel($rel) if $rel;

            # Send to callback
            return $cb->($xrd, $xrd_res->headers->clone);
          };

          # Fail
          return $cb->(undef);
        });
    }
  );

  # Wait if IOLoop is not running
  $delay->wait unless Mojo::IOLoop->is_running;
  return;
};


1;


__END__