package Net::OAuth::Client;
use warnings;
use strict;
use base qw(Class::Accessor::Fast);
__PACKAGE__->mk_accessors(qw/id secret callback is_v1a user_agent site debug session allow_v1a_downgrade/);
use LWP::UserAgent;
use URI;
use Net::OAuth;
use Net::OAuth::Message;
use Net::OAuth::AccessToken;
use Carp;
use Crypt::SysRandom qw( random_bytes );

our $VERSION = '0.33';

=head1 NAME

Net::OAuth::Client - OAuth 1.0A Client

=head1 SYNOPSIS

  use Net::OAuth::Client;

  # client_id is the Consumer Key, client_secret the Consumer Secret.
  # Framework-agnostic: supply your own redirect and session handling.

  my $client = Net::OAuth::Client->new(
      $client_id,
      $client_secret,
      site               => 'https://provider.example/',
      request_token_path => '/oauth/request_token',
      authorize_path     => '/oauth/authorize',
      access_token_path  => '/oauth/access_token',
      callback           => 'https://you.example/auth/callback',
      session            => \&session,
  );

  # 1. Send the user to the provider to authorize.
  $client->authorize_url;

  # 2. They return to your callback with oauth_token and oauth_verifier.
  my $access_token = $client->get_access_token($token, $verifier);

  # 3. Use the access token to fetch a protected resource.
  my $response = $access_token->get('/profile');
  die $response->status_line unless $response->is_success;
  print $response->decoded_content;

=head1 DESCRIPTION

Net::OAuth::Client represents an OAuth client or consumer.

WARNING: Net::OAuth::Client is alpha code.  The rest of Net::OAuth is quite
stable but this particular module is new, and is under-documented and under-tested.


=head1 METHODS

=over

=item new($client_id, $client_secret, %params)

Create a new Client

=over

=item * $client_id

AKA Consumer Key - you get this from the service provider when you register your application.

=item * $client_secret

AKA Consumer Secret - you get this from the service provider when you register your application.

=item * $params{site}

=item * $params{request_token_path}

=item * $params{authorize_path}

=item * $params{access_token_path}

=item * $params{callback}

=item * $params{session}

=item * $params{allow_v1a_downgrade}

Permit the fallback to OAuth 1.0 described in L</OAUTH 1.0A AND THE
CALLBACK CONFIRMATION>. Off by default.

=back

=back

=head2 OAUTH 1.0A AND THE CALLBACK CONFIRMATION

Passing a C<callback> to C<new> selects OAuth 1.0a. In 1.0a the service
provider echoes C<oauth_callback_confirmed> in its request token response,
and later hands the user back with an C<oauth_verifier> that the client
must present when it exchanges the request token for an access token.

If the provider's request token response does not contain
C<oauth_callback_confirmed>, this client cannot use 1.0a. It used to drop
back to plain OAuth 1.0 by itself, and that fallback was invisible: the
access token request is then built from the 1.0 message class, which has
no C<verifier> parameter, so C<oauth_verifier> is quietly left off the
wire even when the caller passed one to L</get_access_token>. The verifier
is exactly what 1.0a added to stop an attacker starting a flow, getting a
victim to authorize the attacker's request token, and then completing the
exchange - so an application that asked for 1.0a and silently got 1.0 is
open to that, with nothing to tell it so.

C<get_request_token> now croaks in that situation instead. An application
that has to talk to a provider which is not 1.0a can opt in with

  allow_v1a_downgrade => 1

which restores the fallback and warns rather than dying.

=cut

sub new {
  my $class = shift;
  my $client_id = shift;
  my $client_secret = shift;
  my %opts = @_;
  $opts{user_agent} ||= LWP::UserAgent->new;
  $opts{id} = $client_id;
  $opts{secret} = $client_secret;
  $opts{is_v1a} = defined $opts{callback};
  my $self = bless \%opts, $class;
  return $self;
}

sub request {
  my $self = shift;
  my $response = $self->user_agent->request(@_);
}

sub _parse_oauth_response {
  my $self = shift;
  my $do_what = shift;
  my $http_res = shift;
  my $msg = "Unable to $do_what: Request for " . $http_res->request->uri . " failed";
  unless ($http_res->is_success) {
    if ($self->debug) {
      $msg .= "," . $http_res->as_string . " ";
    }
    elsif (
      $http_res->content_type eq 'application/x-www-form-urlencoded'
      and $http_res->decoded_content =~ /\boauth_problem=(\w+)/
      ) {
      $msg .= ", reason: " . $1;
    }
    else {
      $msg .= ": " . $http_res->status_line . " (pass debug=>1 to Net::OAuth::Client->new to dump the entire response)";
    }
    croak $msg;
  }
  my $oauth_res = _parse_url_encoding($http_res->decoded_content);
  foreach my $k (qw/token token_secret/) {
    croak "Unable to $do_what: server response is missing '$k'" unless defined $oauth_res->{$k};
  }
  return $oauth_res;

}

sub _parse_url_encoding {
  my $str = shift;
  my @pairs = split '&', $str;
  my %params;
	foreach my $pair (@pairs) {
        my ($k,$v) = split /=/, $pair;
        if (defined $k and defined $v) {
            $v =~ s/(^"|"$)//g;
            ($k,$v) = map Net::OAuth::Message::decode($_), $k, $v;
            $k =~ s/^oauth_//;
            $params{$k} = $v;
        }
    }
	return \%params;
}

sub get_request_token {
  my $self = shift;
  my %params = @_;
  my $oauth_req = $self->_make_request(
    "request token",
    request_method => $self->request_token_method,
    request_url => $self->_make_url("request_token"),
    %params
  );
  $oauth_req->sign;
  my $http_res = $self->request(HTTP::Request->new(
    $self->request_token_method => $oauth_req->to_url
  ));
  my $oauth_res = $self->_parse_oauth_response('get a request token', $http_res);
  if ($self->is_v1a and !defined $oauth_res->{callback_confirmed}) {
    # The application asked for OAuth 1.0a by configuring a callback and the
    # provider did not confirm it.  Dropping to 1.0 here also drops
    # oauth_verifier from the access token request further down, which is
    # the parameter 1.0a added to prevent session fixation, so this is not a
    # decision to take on the application's behalf without telling it.
    croak "Unable to get a request token: the service provider did not "
        . "confirm the OAuth 1.0a callback (no oauth_callback_confirmed in "
        . "its response). Pass allow_v1a_downgrade => 1 to "
        . "Net::OAuth::Client->new to fall back to OAuth 1.0 instead"
      unless $self->allow_v1a_downgrade;
    carp "Net::OAuth::Client warning: service provider did not confirm the "
       . "OAuth 1.0a callback; falling back to OAuth 1.0, so oauth_verifier "
       . "will not be sent";
    $self->is_v1a(0);
  }
  return $oauth_res;
}

sub authorize_url {
  my $self = shift;
  my %params = @_;
  # allow user to get request token their own way
  unless (defined $params{token} and defined $params{token_secret}) {
    my $request_token = $self->get_request_token;
    $params{token} = $request_token->{token};
    $params{token_secret} = $request_token->{token_secret};
  }
  if (defined $self->session) {
    $self->session->($params{token} => $params{token_secret});
  }
  my $oauth_req = $self->_make_request(
    'user auth',
    %params
  );
  return $oauth_req->to_url($self->_make_url('authorize'));
}

sub get_access_token {
  my $self = shift;
  my $token = shift;
  my $verifier = shift;
  my %params = @_;

  if (defined $self->session) {
    $params{token_secret} = $self->session->($token);
  }

  # In OAuth 1.0 mode the access token request class has no verifier message
  # parameter, so gather_message_parameters() would drop this on the floor
  # without a word.  Say so rather than sending a request that is missing
  # the credential the caller believed it was presenting.
  if (defined $verifier and !$self->is_v1a) {
    carp "Net::OAuth::Client warning: an oauth_verifier was supplied but "
       . "this client is in OAuth 1.0 mode, so it will not be sent";
  }

  my $oauth_req = $self->_make_request(
    'access token',
    request_method => $self->access_token_method,
    request_url => $self->_make_url('access_token'),
    token => $token,
    verifier => $verifier,
    %params
  );
  $oauth_req->sign;

  my $http_res = $self->request(HTTP::Request->new(
    $self->access_token_method => $oauth_req->to_url
  ));

  my $oauth_res = $self->_parse_oauth_response('get an access token', $http_res);

  return Net::OAuth::AccessToken->new(%$oauth_res, client => $self);
}

sub access_token_url {
  return shift->_make_url('access_token', @_);
}

sub request_token_url {
  return shift->_make_url('request_token', @_);
}

sub access_token_method {
  return shift->{access_token_method} || 'GET';
}

sub request_token_method {
  return shift->{request_token_method} || 'GET';
}

sub _make_request {
  my $self = shift;
  my $type = shift;
  my %params = @_;
  my %defaults = (
    timestamp => time,
    consumer_key => $self->id,
    consumer_secret => $self->secret,
    callback => $self->callback,
    signature_method => 'HMAC-SHA1',
    request_method => 'GET',
  );
  $defaults{nonce} = unpack("H*", random_bytes(16)) unless exists $params{nonce};
  $defaults{protocol_version} = Net::OAuth::PROTOCOL_VERSION_1_0A if $self->is_v1a;
  my $req = Net::OAuth->request($type)->new(
    %defaults,
    %params
  );
  return $req;
}

sub _make_url {
  my $self = shift;
  my $thing = shift;
  my $path = $self->{"${thing}_url"} || $self->{"${thing}_path"} || "/oauth/${thing}";
  return $self->site_url($path, @_);
}

sub site_url {
  my $self = shift;
  my $path = shift;
  my %params = @_;
  my $url;
  if (defined $self->{site}) {
    $url = URI->new_abs($path, $self->{site});
  }
  else {
    $url = URI->new($path);
  }
  if (@_) {
    $url->query_form($url->query_form , %params);
  }
  return $url;
}

=head1 AUTHOR

Originally by Keith Grennan <foss@nearlyfree.org>

Currently maintained by Robert Rothenberg <perl@rhizomnic.com>

=head1 LICENSE AND COPYRIGHT

Copyright 2007-2012, 2024-2026 Keith Grennan

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

1;
