File Coverage

blib/lib/WebService/Soundcloud.pm

Criterion	Covered	Total	%
statement	120	261	45.9
branch	28	94	29.7
condition	2	18	11.1
subroutine	25	38	65.7
pod	21	21	100.0
total	196	432	45.3

package WebService::Soundcloud;

use 5.006;

use strict;
use warnings;

use Carp;
use LWP::UserAgent;
use URI;
use JSON qw(decode_json);
use Data::Dumper;
use HTTP::Headers;
use Scalar::Util qw(reftype);

# declare domains
our %domain_for = (
   'prod'        => 'https://api.soundcloud.com/',
   'production'  => 'https://api.soundcloud.com/',
   'development' => 'https://api.sandbox-soundcloud.com/',
   'dev'         => 'https://api.sandbox-soundcloud.com/',
   'sandbox'     => 'https://api.sandbox-soundcloud.com/'
);

our $DEBUG    = 0;
our %path_for = (
   'authorize'    => 'connect',
   'access_token' => 'oauth2/token'
);

our %formats = (
   '*'    => '*/*',
   'json' => 'application/json',
   'xml'  => 'application/xml'
);

our $VERSION = '0.04';

=pod

=head1 NAME

WebService::Soundcloud - Thin wrapper around Soundcloud RESTful API!

=head1 VERSION

Version 0.02

=head1 SYNOPSIS

    #!/usr/bin/perl
    use WebService::Soundcloud;

    my $scloud = WebService::Soundcloud->new($client_id, $client_secret,
                           { redirect_uri => 'http://mydomain.com/callback' }
                         );

    # Now get authorization url
    my $authorization_url = $scloud->get_authorization_url();

    # Redirect the user to authorization url
    use CGI;
    my $q = new CGI;
    $q->redirect($authorization_url);

    # In your '/callback' handler capture code params
    # Check for error
    if ($q->param(error)) {
    	die "Authorization Failed: ". $q->param('error');
    }
    # Get authorization code
    my $code = $q->param('code');

    # Get Access Token
    my $access_token = $scloud->get_access_token($code);

    # Save access_token and refresh_token, expires_in, scope for future use
    my $oauth_token = $access_token->{access_token};

    # OAuth Dance is completed :-) Have fun now.

    # Default request and response formats are 'json'

    # a GET request '/me' - gets users details
    my $user = $scloud->get('/me');

    # a PUT request '/me' - updated users details
    my $user = $scloud->put('/me', encode_json(
                { 'user' => {
                  'description' => 'Have fun with Perl wrapper to Soundcloud API'
                } } ) );

    # Comment on a Track POSt request usage
    my $comment = $scloud->post('/tracks//comments',
                            { body => 'I love this hip-hop track' } );

    # Delete a track
    my $track = $scloud->delete('/tracks/{id}');

    # Download a track
    my $file_path = $scloud->download('', $dest_file);


=head1 DESCRIPTION

This module provides a wrapper around Soundcloud RESTful API to work with
different kinds of soundcloud resources. It contains many functions for
convenient use rather than standard Soundcloud RESTful API.

The complete API is documented at http://developers.soundcloud.com/docs.

In order to use this module you will need to register your application
with Soundcloud at http://soundcloud.com/you/apps : your application will
be given a client ID and a client secret which you will need to use to
connect.

=head2 METHODS

=over 4

=item new

Returns a newly created C object. The first
argument is $client_id, the second argument is $client_secret - these
are required and will have been provided when you registered your
application with Soundcloud The third optional argument is a
HASHREF that contains additional parameters that may be required:

=over 4

=item redirect_uri

This is the URI of your application to which the user will be redirected
after they have authorised the connection with Soundcloud.  This should
be the same as the one provided when you registered your application and
will be required for most applications.

=back

=cut

sub new
{
   my ($class, $client_id, $client_secret, $options ) = @_;

   if(!defined $client_id && !defined $client_secret )
   {
       croak "Client ID and Secret required";
   }

   $options = {} unless defined $options;

   my $self = bless $options, $class;

   $self->client_id($client_id);
   $self->client_secret($client_secret);

   $options->{debug}         = $DEBUG unless ( $options->{debug} );


   return $self;
}

=item client_id

Accessor for the Client ID that was provided when you registered your
application.

=cut

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

   if ( defined $client_id )
   {
       $self->{client_id} = $client_id;
   }

   return $self->{client_id};
}

=item client_secret

Accessor for the Client Secret that was provided when you registered
your application.

=cut

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

   if ( defined $client_secret )
   {
       $self->{client_secret} = $client_secret;
   }

   return $self->{client_secret};
}

=item redirect_uri

Accessor for the redirect_uri this can be passed as an option to the
constructor or supplied later (before any connect call.) This should
match to that provided when you registered your application.

It is the URI of your application that the user will be redirected
(with the authorization code as a parameter,) after they have clicked
"Connect" on the soundcloud connect page.  This will not be used if
you are using the credential based authentication to obtain the OAuth token
(e.g if you are an application with no UI that is operating for a single
user.)

=cut

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

   if ( defined $redirect_uri )
   {
       $self->{redirect_uri} = $redirect_uri;
   }

   return $self->{redirect_uri};
}

=item basic_params

This returns a HASHREF that is suitable to be used as the basic parameters
in most places, containing the application credentials (ID and Secret) and
redirect_uri

=cut

sub basic_params
{
    my ( $self ) = @_;

    my $params = {
        client_id => $self->client_id(),
        client_secret   => $self->client_secret(),
    };

    if ( defined $self->redirect_uri() )
    {
        $params->{redirect_uri} = $self->redirect_uri();
    }

    return $params;

}

=item ua

Returns the L object that will be used to connect to the
API host

=cut

sub ua
{
    my ( $self ) = @_;

    if (!defined $self->{user_agent} )
    {
        $self->{user_agent} = LWP::UserAgent->new();
    }

    return $self->{user_agent};
}

=item get_authorization_url

This method is used to get authorization url, user should be redirected
for authenticate from soundcloud. This will return URL to which user
should be redirected.

=cut

sub get_authorization_url
{
   my ( $self, $args ) = @_;
   my $call   = 'get_authorization_url';
   my $params = $self->basic_params();

   $params->{response_type} = 'code';

   $params = { %{$params}, %{$args} } if ref($args) eq 'HASH';
   my $authorize_url = $self->_build_url( $path_for{'authorize'}, $params );
   return $authorize_url;
}

=item get_access_token

This method is used to receive access_token, refresh_token,
scope, expires_in details from soundcloud once user is
authenticated. access_token, refresh_token should be stored as it should
be sent along with every request to access private resources on the
user behalf.

The argument C<$code> is required unless you are using credential based
authentication, and will have been supplied to your C after
the user pressed "Connect" on the soundcloud connect page.

=cut

sub get_access_token
{
   my ( $self, $code, $args ) = @_;
   my $request;
   my $call   = 'get_access_token';
   my $params = $self->_access_token_params($code);

   $params = { %{$params}, %{$args} } if ref($args) eq 'HASH';
   return $self->_access_token($params);
}

=item _access_token_params

=cut

sub _access_token_params
{
   my ( $self, $code ) = @_;

   my $params = $self->basic_params();

   if ( $self->{scope} )
   {
      $params->{scope} = $self->{scope};
   }
   if ( $self->{username} && $self->{password} )
   {
      $params->{username}   = $self->{username};
      $params->{password}   = $self->{password};
      $params->{grant_type} = 'password';
   }
   elsif ( defined $code )
   {
      $params->{code}       = $code;
      $params->{grant_type} = 'authorization_code';
   }
   else
   {
      die "neither credentials or auth code provided";
   }

   return $params;
}

=item get_access_token_refresh

This method is used to get new access_token by exchanging refresh_token
before the earlier access_token is expired. You will receive new
access_token, refresh_token, scope and expires_in details from
soundcloud. access_token, refresh_token should be stored as it should
be sent along with every request to access private resources on the
user behalf.

If a C of 'non-expiring' was supplied at the time the initial tokem
was obtained then this should not be necessary.

=cut

sub get_access_token_refresh
{
   my ( $self, $refresh_token, $args ) = @_;

   my $params = $self->basic_params();

   $params->{refresh_token} = $refresh_token;
   $params->{grant_type}    = 'refresh_token';

   $params = { %{$params}, %{$args} } if ref($args) eq 'HASH';
   return $self->_access_token($params);
}

=item request

This performs an HTTP request with the $method supplied to the supplied
$url. The third argument $headers can be supplied to insert any required
headers into the request, if $content is supplied it will be processed
appropriately and inserted into the request.

An L will be returned and this should be checked to
determine the status of the request.

=cut

sub request
{
   my ( $self, $method, $url, $headers, $content ) = @_;
   my $req = HTTP::Request->new( $method, $url, $headers );

   if ( defined $content )
   {
      my $u = URI->new();
      $u->query_form($content);
      my $query = $u->query();
      $req->content($query);
   }
   $self->log($req->as_string());
   return $self->ua()->request($req);
}

=item get_object

This returns a decoded object corresponding to the URI given

It will for the response_format to 'json' for the request as
parsing the XML is tricky given no schema.

=cut

sub get_object
{
   my ( $self, $url, $params, $headers ) = @_;

   my $obj;

   my $save_response_format = $self->response_format();
   $self->response_format('json');

   my $res = $self->get( $url, $params, $headers );

   if ( $res->is_success() )
   {
      $obj = decode_json( $res->decoded_content() );
   }

   $self->response_format($save_response_format);

   return $obj;
}

=item get_list

This returns a decoded LIST REF of the list method specified by URI

Currently this will force response_format to 'json' as parsin the XML
is tricky without a schema.

=cut

sub get_list
{
   my ( $self, $url, $params, $headers ) = @_;

   my $ret      = [];
   my $continue = 1;
   my $offset   = 0;
   my $limit    = 50;

   my $save_response_format = $self->response_format();
   $self->response_format('json');

   if ( !defined $params )
   {
      $params = {};
   }
   while ($continue)
   {
      $params->{limit}  = $limit;
      $params->{offset} = $offset;

      my $res = $self->get( $url, $params, $headers );

      if ( $res->is_success() )
      {
         if (defined(my $obj = $self->parse_content( $res->decoded_content())))
         {
             if (defined (my $type = reftype($obj) ) )
             {
                 if ( $type eq 'ARRAY' )
                 {
                     $offset += $limit;
                     $continue = scalar @{$obj};
                 }
                 elsif ( $type eq 'HASH' )
                 {
                     if ( exists $obj->{collection} )
                     {
                        if(!defined($url = $obj->{next_href}))
                        {
                            $continue = 0;
                        }
                        $obj = $obj->{collection};
                     }
                     else
                     {
                         croak "not a collection";
                     }
                 }
                 else
                 {
                     croak "Unexpected $type reference instead of list";
                 }
                  push @{$ret}, @{$obj};
             }
         }
         else
         {
             $continue = 0;
         }
      }
      else
      {
         warn $res->request()->uri();
         die $res->status_line();
      }
   }

   $self->response_format($save_response_format);

   return $ret;
}

=item get(, , )

This method is used to dispatch GET request on the give URL(first argument).
second argument is an anonymous hash request parameters to be send along with GET request.
The third optional argument() is used to send headers.
This method will return HTTP::Response object

=cut

sub get
{
   my ( $self, $path, $params, $extra_headers ) = @_;
   my $url = $self->_build_url( $path, $params );
   my $headers = $self->_build_headers($extra_headers);
   return $self->request( 'GET', $url, $headers );
}

=item I<$OBJ>->post(, , )

This method is used to dispatch POST request on the give URL(first argument).
second argument is the content to be posted to URL.
The third optional argument() is used to send headers.
This method will return HTTP::Response object

=cut

sub post
{
   my ( $self, $path, $content, $extra_headers ) = @_;
   my $url     = $self->_build_url($path);
   my $headers = $self->_build_headers($extra_headers);
   return $self->request( 'POST', $url, $headers, $content );
}

=item I<$OBJ>->put(, , )

This method is used to dispatch PUT request on the give URL(first argument).
second argument is the content to be sent to URL.
The third optional argument() is used to send headers.
This method will return HTTP::Response object

=cut

sub put
{
   my ( $self, $path, $content, $extra_headers ) = @_;
   my $url = $self->_build_url($path);

# Set Content-Length Header as well otherwise nginx will throw 411 Length Required ERROR
   $extra_headers->{'Content-Length'} = 0
     unless $extra_headers->{'Content-Length'};
   my $headers = $self->_build_headers($extra_headers);
   return $self->request( 'PUT', $url, $headers, $content );
}

=item I<$OBJ>->delete(, , )

This method is used to dispatch DELETE request on the give URL(first argument).
second optional argument is an anonymous hash request parameters to be send
along with DELETE request. The third optional argument() is used to
send headers. This method will return HTTP::Response object

=cut

sub delete
{
   my ( $self, $path, $params, $extra_headers ) = @_;
   my $url = $self->_build_url( $path, $params );
   my $headers = $self->_build_headers($extra_headers);
   return $self->request( 'DELETE', $url, $headers );
}

=item I<$OBJ>->download(, )

This method is used to download a particular track id given as first argument.
second argument is name of the destination path where the downloaded track will
be saved to. This method will return the file path of downloaded track.

=cut

sub download
{
   my ( $self, $trackid, $file ) = @_;
   my $url = $self->_build_url( "/tracks/$trackid/download", {});
   $self->log($url);

   my $rc = 0;
   # Set Response format to */*
   # Memorize old response format
   my $old_response_format = $self->{response_format};
   $self->response_format('*');
   my $headers = $self->_build_headers();
   $self->ua()->add_handler('response_redirect',\&_our_redirect);
   my $response = $self->request( 'GET', $url, $headers );

   $self->ua()->remove_handler('response_redirect');

   if (!($rc = $response->is_success()))
   {

       $self->log($response->request()->as_string());
       $self->log($response->as_string());
       foreach my $red ( $response->redirects() )
       {
           $self->log($red->request()->as_string());
           $self->log($red->as_string());
       }
   }
   # Reset response format
   $self->{response_format} = $formats{$old_response_format};
   return $rc;
}

=item _our_redirect

This subroutime is intended to be used as a callback on 'response_redirect'
It processes the response to make a new request for the redirect with the
Authorization header removed so that EC3 doesn't get confused.

=cut

sub _our_redirect
{
   my ( $response, $ua, $h ) = @_;

   my $code = $response->code();

   my $req;

   if (_is_redirect($code) )
   {
       my $referal =  $response->request()->clone();
       $referal->remove_header('Host','Cookie','Referer','Authorization');

       if (my $ref_uri = $response->header('Location'))
       {
           my $uri = URI->new($ref_uri);
           $referal->header('Host' => $uri->host());
         $referal->uri($uri);
         if ( $ua->redirect_ok($referal, $response) )
         {
             $req = $referal;
         }
       }
   }

   return $req;
}

=item _is_redirect

Helper subroutine to determine if the code indicates a redirect.

=cut

sub _is_redirect
{
   my ($code) = @_;

   my $rc = 0;

   if ( defined $code )
   {
      if (  $code == &HTTP::Status::RC_MOVED_PERMANENTLY
         or $code == &HTTP::Status::RC_FOUND
         or $code == &HTTP::Status::RC_SEE_OTHER
         or $code == &HTTP::Status::RC_TEMPORARY_REDIRECT )
      {
         $rc = 1;
      }
   }
   return $rc;
}

=item request_format

Accessor for the request format to be used.  Acceptable values are 'json' and
'xml'.  The default is 'json'.
=cut

sub request_format
{
   my ( $self, $format ) = @_;

   if ($format)
   {
      $self->{request_format} = $format;
   }
   elsif(!defined $self->{request_format})
   {
      $self->{request_format} = 'json';
   }

   return $self->{request_format};
}

=item response_format

Accessor for the response format to be used.  The allowed values are 'json'
and 'xml'.  The default is 'json'.  This will cause the appropriate setting
of the Accept header in requests.

=cut

sub response_format
{
   my ( $self, $format ) = @_;
   if ($format)
   {
      $self->{response_format} = $format;
   }
   elsif (!defined $self->{response_format})
   {
      $self->{response_format} = 'json';
   }
   return $self->{response_format};
}

=item parse_content

This will return the parsed object corresponding to the response content
passed as asn argument.  It will select the appropriate parser based on the
value of 'response_format'.

It will return undef if there is a problem with the parsing.

=cut

sub parse_content
{
    my ( $self, $content ) = @_;

    my $object;

   if ( defined $content )
   {

      eval
      {
          if ( $self->response_format() eq 'json' )
          {
              $object = decode_json($content);
          }
          elsif ( $self->response_format() eq 'xml' )
          {
              require XML::Simple;
              my $xs = XML::Simple->new();
              $object = $xs->XMLin($content);
          }
      };
      if ( $@ )
      {
          warn $@;
      }
   }
    return $object;
}

=back

=head1 INTERNAL SUBROUTINES/METHODS

Please do not use these internal methods directly. They are internal to
WebService::Soundcloud module itself. These can be renamed/deleted/updated at any point
of time in future.

=over 4

=item I<$OBJ>->_access_token()

This method is used to get access_token from soundcloud. This will be called
from get_access_token and get_access_token_refresh methods.

=cut

sub _access_token
{
   my ( $self, $params ) = @_;
   my $call     = '_access_token';
   my $url      = $self->_access_token_url();
   my $headers  = $self->_build_headers();
   my $response = $self->request( 'POST', $url, $headers, $params );
   die "Failed to fetch "
     . $url . " "
     . $response->content() . " ("
     . $response->status_line() . ")"
     unless $response->is_success;
   my $uri          = URI->new;
   my $access_token = decode_json( $response->decoded_content );

   # store access_token, refresh_token
   foreach (qw(access_token refresh_token expire expires_in))
   {
      $self->{$_} = $access_token->{$_};
   }

   # set access_token, refresh_token
   return $access_token;
}

=item I<$OBJ>->_access_token_url()

This method is used to get access_token_url of soundcloud RESTful API.
This will be called from _access_token method.

=cut

sub _access_token_url
{
   my ( $self, $params ) = @_;
   my $url = $self->_build_url( $path_for{'access_token'}, $params );
   return $url;
}

=item I<$OBJ>->_build_url(, PARAMS>)

This method is used to prepare absolute URL for a given path and request parameters.

=cut

sub _build_url
{
   my ( $self, $path, $params ) = (@_);
   my $call = '_build_url';

   # get base URL
   my $base_url =
     $self->{development} ? $domain_for{development} : $domain_for{production};

   #$params->{client_id} = $self->client_id();
   # Prepare URI Object
   my $uri = URI->new_abs( $path, $base_url );

   if ( $uri->query() )
   {
       $params = { %{$params || {}}, $uri->query_form() };
   }
   $uri->query_form( %{$params} );
   return $uri;
}

=item I<$OBJ>->_build_headers()

This method is used to set extra headers to the current HTTP Request.

=cut

sub _build_headers
{
   my ( $self, $extra ) = @_;
   my $headers = HTTP::Headers->new;

   $headers->header( 'Accept' => $formats{ $self->{response_format} } )
     if ( $self->{response_format} );
   $headers->header( 'Content-Type' => $formats{ $self->{request_format} } . '; charset=utf-8' )
     if ( $self->{request_format} );
   $headers->header( 'Authorization' => "OAuth " . $self->{access_token} )
     if ( $self->{access_token} && !$extra->{no_auth});
   foreach my $key ( %{$extra} )
   {
      $headers->header( $key => $extra->{$key} );
   }
   return $headers;
}

=item I<$OBJ>->log()

This method is used to write some text to STDERR.

=cut

sub log
{
   my ( $self, $msg ) = @_;
   if ( $self->{debug} )
   {
      print STDERR "$msg\n";
   }
}

=back

=head1 AUTHOR

Mohan Prasad Gutta, C<<  >>

=head1 CONTRIBUTORS

Jonathan Stowe C

=head1 BUGS

Parts of this are extremely difficult to test properly so there almost
certainly will be bugs, please feel free to fix and send me a patch if
you find one.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.
    perldoc WebService::Soundcloud
    You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)
L

=item * AnnoCPAN: Annotated CPAN documentation
L

=item * CPAN Ratings
L

=item * Search CPAN
L

=back

=head1 LICENSE AND COPYRIGHT

Copyright 2013 Mohan Prasad Gutta.
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;