File Coverage

lib/LWP/Authen/OAuth2/ServiceProvider.pm

Criterion	Covered	Total	%
statement	61	166	36.7
branch	5	52	9.6
condition	0	6	0.0
subroutine	24	35	68.5
pod	10	26	38.4
total	100	285	35.0

package LWP::Authen::OAuth2::ServiceProvider;

# ABSTRACT: ServiceProvider base class
our $VERSION = '0.19'; # VERSION

use 5.006;
use strict;
use warnings;

use Carp qw(confess croak);
use JSON qw(decode_json);
use Memoize qw(memoize);
use Module::Load qw(load);
use URI;

our @CARP_NOT = qw(LWP::Authen::OAuth2 LWP::Authen::OAuth2::Args);

use LWP::Authen::OAuth2::Args qw(
    extract_option copy_option assert_options_empty
);

# Construct a new object.
sub new {
    my ($class, $opts) = @_;

    # I start as an empty hashref.
    my $self = {};

    # But what class am I supposed to actually be?
    if (not exists $opts->{service_provider}) {
        bless $self, $class;
    }
    else {
        # Convert "Google" to "LWP::Authen::OAuth2::ServiceProvider::Google"
        # Not a method because no object yet exists.
        $class = service_provider_class(delete $opts->{service_provider});
        my $client_type = delete $opts->{client_type};
        if (not defined($client_type)) {
            $client_type = "default";
        }
        bless $self, $class->client_type_class($client_type);
    }

    $self->init($opts);
}

sub init {
    my ($self, $opts) = @_;

    # Now let us consume options.  2 args = required, 3 = defaulted.
    # In general subclasses should Just Work.

    # need to read this first, since the later opts depend on it
    $self->copy_option($opts, 'use_test_urls') if defined $opts->{use_test_urls};

    # These are required, NOT provided by this class, but are by subclasses.
    for my $field (qw(token_endpoint authorization_endpoint)) {
        if ($self->can($field)) {
            $self->copy_option($opts, $field, $self->$field);
        }
        else {
            $self->copy_option($opts, $field);
        }
    }

    # These are defaulted by this class, maybe overridden by subclasses.
    for my $field (
        qw(required_init optional_init),
        map {
            ("$_\_required_params", "$_\_optional_params")
        } qw(authorization request refresh)
    ) {
        $self->copy_option($opts, $field, [$self->$field]);
    }

    # And hashrefs for default key/value pairs.
    for my $field (
        map "$_\_default_params", qw(authorization request refresh)
    ) {
        $self->copy_option($opts, $field, {$self->$field});
    }

    return $self;
}

sub authorization_url {
    my ($self, $oauth2, @rest) = @_;
    my $param
        = $self->collect_action_params("authorization", $oauth2, @rest);
    my $uri = URI->new($self->authorization_endpoint());
    $uri->query_form(%$param);
    return $uri->as_string;
}

sub request_tokens {
    my ($self, $oauth2, @rest) = @_;
    my $param = $self->collect_action_params("request", $oauth2, @rest);
    my $response = $self->post_to_token_endpoint($oauth2, $param);
    return $self->construct_tokens($oauth2, $response);
}

sub can_refresh_tokens {
    my ($self, $oauth2, %opt) = @_;
    my %default = $self->refresh_default_params;
    my $oauth2_args = $oauth2->for_service_provider;
    for my $param ($self->refresh_required_params) {
        if ( exists $default{$param}
          or exists $oauth2_args->{$param}
          or exists $opt{$param}
        ) {
            next;
        }
        else {
            return 0;
        }
    }
    return 1;
}

sub refreshed_tokens {
    my ($self, $oauth2, @rest) = @_;
    my $param = $self->collect_action_params("refresh", $oauth2, @rest);
    my $response = $self->post_to_token_endpoint($oauth2, $param);
    # Error message or object, this is what we return.
    return $self->construct_tokens($oauth2, $response);
}

sub collect_action_params {
    my $self = shift;
    my $action = shift;
    my $oauth2 = shift;
    my $oauth2_args = $oauth2->for_service_provider;
    my @rest = @_;
    my $opt = {@_};

    my $default = $self->{"$action\_default_params"};

    if ($oauth2->is_strict) {
        # We copy one by one with testing.
        my $result = {};
        for my $param (@{ $self->{"$action\_required_params"}}) {
             if (exists $opt->{$param}) {
                 if (defined $opt->{$param}) {
                     $result->{$param} = delete $opt->{$param};
                 }
                 else {
                     croak("Cannot pass undef for required param '$param'");
                 }
             }
             elsif (defined $oauth2_args->{$param}) {
                 $result->{$param} = $oauth2_args->{$param};
             }
             elsif (defined $default->{$param}) {
                 $result->{$param} = $default->{$param};
             }
             else {
                 croak("Missing required param '$param'");
             }
        }

        for my $param (@{ $self->{"$action\_optional_params"} }) {
            for my $source ($result, $opt, $oauth2_args, $default) {
                if (exists $source->{$param}) {
                    # Only add it if it is not undef.  Else hide.
                    if (defined $source->{$param}) {
                        $result->{$param} = $source->{$param};
                    }

                    # For opt only, delete if it was found.
                    if ($opt == $source) {
                        delete $opt->{$param};
                    }

                    last; # source
                    # (undef is deliberate override, which is OK)
                }
            }
        }

        $self->assert_options_empty($opt);

        # End of strict section.
        return $result;
    }
    else {
        # Not strict  just bulk copy.
        my $result = {
            %$default,
            (
                map {($_, $oauth2_args->{$_})}
                    @{ $self->{"$action\_required_params"} },
                    @{ $self->{"$action\_optional_params"} }
            ),
            %$opt
        };
        for my $key (keys %$result) {
            if (not defined($result->{$key})) {
                delete $result->{$key};
            }
        }
        return $result;
    }
}

sub post_to_token_endpoint {
    my ($self, $oauth2, $param) = @_;
    my $ua = $oauth2->user_agent();
    return $ua->post($self->token_endpoint(), [%$param]);
}

sub api_url_base { return '' } # override in subclass

sub access_token_class {
    my ($self, $type) = @_;

    if ("bearer" eq $type) {
        return "LWP::Authen::OAuth2::AccessToken::Bearer";
    }
    else {
        return "Token type '$type' not yet implemented";
    }
}

# Attempts to construct tokens, returns the access_token (which may have a
# request token embedded).
sub construct_tokens {
    my ($self, $oauth2, $response) = @_;

    # The information that I need.
    my $content = eval {$response->decoded_content};
    if (not defined($content)) {
        $content = '';
    }
    my $data = eval {decode_json($content)};
    my $parse_error = $@;
    my $token_endpoint = $self->token_endpoint();

    # Can this have done wrong?  Let me list the ways...
    if ($parse_error) {
        # "Should not happen", hopefully just network.
        # Tell the programmer everything.
        my $status = $response->status_line;
        return <<"EOT"
Token endpoint gave invalid JSON in response.

Endpoint: $token_endpoint
Status: $status
Parse error: $parse_error
JSON:
$content
EOT
    }
    elsif ($data->{error}) {
        # Assume a valid OAuth 2 error message.
        my $message = "OAuth2 error: $data->{error}";

        # Do we have a mythical service provider that gives us more?
        if ($data->{error_uri}) {
            # They seem to have a web page with detail.
            $message .= "\n$data->{error_uri} may say more.\n";
        }

        if ($data->{error_description}) {
            # Wow!  Thank you!
            $message .= "\n\nDescription: $data->{error_description}\n";
        }
        return $message;
    }
    elsif (not $data->{token_type}) {
        # Someone failed to follow the spec...
        return <<"EOT";
Token endpoint missing expected token_type in successful response.

Endpoint: $token_endpoint
JSON:
$content
EOT
    }

    my $type = $self->access_token_class(lc($data->{token_type}));
    if ($type !~ /^[\w\:]+\z/) {
        # We got an error. :-(
        return $type;
    }

    eval {load($type)};
    if ($@) {
        # MAKE THIS FATAL.  (Clearly Perl code is simply wrong.)
        confess("Loading $type for $data->{token_type} gave error: $@");
    }

    # Try to make an access token.
    my $access_token = $type->from_ref($data);

    if (not ref($access_token)) {
        # This should be an error message of some sort.
        return $access_token;
    }
    else {
        # WE SURVIVED!  EVERYTHING IS GOOD!
        if ($oauth2->access_token) {
            $access_token->copy_refresh_from($oauth2->access_token);
        }
        return $access_token;
    }
}

# Override for your client_types if you have multiple.
sub client_type_class {
    my ($class, $name) = @_;
    if ("default" eq $name) {
        return $class;
    }
    else {
        croak("Flow '$name' not defined for '$class'");
    }
}

# Override should you need the front-end LWP::Authen::OAuth object to have
# methods for service provider specific functionality.
#
# This is not expected to be a common need.
sub oauth2_class {
    return "LWP::Authen::OAuth2";
}

memoize("service_provider_class");
sub service_provider_class {
    my $short_name = shift;
    eval {
        load("LWP::Authen::OAuth2::ServiceProvider::$short_name");
    };
    if (not $@) {
        return "LWP::Authen::OAuth2::ServiceProvider::$short_name";
    }
    elsif ($@ =~ /Compilation failed/) {
        confess($@);
    }
    else {
        eval {
            load($short_name);
        };
        if (not $@) {
            return $short_name;
        }
        elsif ($@ =~ /Compilation failed/) {
            confess($@);
        }
        else {
            croak("Service provider '$short_name' not found");
        }
    }
}

# DEFAULTS (can be overridden)
sub authorization_endpoint {
    my $self = shift;
    return $self->{"authorization_endpoint"};
}

sub token_endpoint {
    my $self = shift;
    return $self->{"token_endpoint"};
}

# DEFAULTS (should be overridden)
sub required_init {
    return qw(client_id client_secret);
}

sub optional_init {
    return qw(redirect_uri scope);
}

sub authorization_required_params {
    return qw(response_type client_id);
}

sub authorization_optional_params {
    return qw(redirect_uri state scope);
}

sub authorization_default_params {
    return qw(response_type code);
}

sub request_required_params {
    return qw(grant_type client_id client_secret code);
}

sub request_optional_params {
    return qw(state redirect_uri);
}

sub request_default_params {
    return qw(grant_type authorization_code);
}

sub refresh_required_params {
        return qw(grant_type refresh_token client_id client_secret);
}

sub refresh_optional_params {
        return qw();
}

sub refresh_default_params {
    return qw(grant_type refresh_token);
}


1

__END__