File Coverage

blib/lib/WebService/NFSN.pm

Criterion	Covered	Total	%
statement	72	148	48.6
branch	19	34	55.8
condition	6	22	27.2
subroutine	19	60	31.6
pod	33	40	82.5
total	149	304	49.0

#---------------------------------------------------------------------
package WebService::NFSN;
#
# Copyright 2010 Christopher J. Madsen
#
# Author: Christopher J. Madsen
# Created: 3 Apr 2007
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either the
# GNU General Public License or the Artistic License for more details.
#
# ABSTRACT: Client for the NearlyFreeSpeech.NET API
#---------------------------------------------------------------------

use 5.006;
use strict;
use warnings;
use Carp qw(carp confess croak);
use Digest::SHA 'sha1_hex';
use Exporter 5.57 'import';     # exported import method
use LWP::UserAgent 6 ();
use Scalar::Util 1.01 'reftype';
use Try::Tiny 0.04;

#=====================================================================
# Package Global Variables:

our $VERSION = '1.03';

our @EXPORT_OK = qw(_eval _eval_or_die);

our $saltAlphabet
    = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789';

our $ua = LWP::UserAgent->new(
  agent => "WebService-NFSN/$VERSION ",
  ssl_opts => {
    verify_hostname => 1,
  },
);

our @throw_parameters = (
  show_trace     => 1,
  ignore_package => __PACKAGE__,
  ignore_class   => 'WebService::NFSN::Object'
);

#=====================================================================
# Helper subs to safely handle string eval without clobbering $@:

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

  my ($error, $success);
  {
    local $@;

    $success = eval "$code ; 'OK'"; ## no critic ProhibitStringyEval

    $error = $@;
  }

  return if $success && $success eq 'OK';

  return $error || "eval died with false \$\@";
} # end _eval

sub _eval_or_die
{
  my $error = &_eval;           # Pass our @_ to _eval

  return unless $error;

  # Number lines in eval'd code:
  my $code = shift;
  my $lineNum = ($code =~ tr/\n//);
  my $fmt = '%' . length($lineNum) . 'd: ';
  $lineNum = 0;
  $code =~ s/^/sprintf $fmt, ++$lineNum/gem;

  confess "$code\n$error";
} # end _eval_or_die

#---------------------------------------------------------------------
# Helper sub to identify a hashref:

sub _is_hash { (reftype($_[0]) || '') eq 'HASH' }

#=====================================================================
# Load a JSON package and define our decode_json function:

BEGIN
{
  if (_eval "use JSON::XS ()") {
    # Can't find JSON::XS, try JSON (2.0 or later):
    _eval_or_die "use JSON qw(decode_json)";
  } else {
    if ($JSON::XS::VERSION >= 2) {
      *decode_json = \&JSON::XS::decode_json;
    } else {
      *decode_json = \&JSON::XS::from_json; # old name for decode_json
    } # end else found JSON::XS prior to version 2.0
  } # end else we were able to load JSON::XS
} # end BEGIN

#=====================================================================
# Define exceptions:

use Exception::Class (
  'WebService::NFSN::HTTPError' => {
    fields => [ qw(request response) ],
  },

    'WebService::NFSN::LWPError' => {
      isa    => 'WebService::NFSN::HTTPError',
    },

    'WebService::NFSN::NFSNError' => {
      isa    => 'WebService::NFSN::HTTPError',
      fields => [ qw(debug nfsn) ],
    },
);

#---------------------------------------------------------------------
# Include both the error & debug fields:

sub WebService::NFSN::NFSNError::full_message
{
  my ($self) = @_;

  $self->error . "\n" . $self->debug;
} # end WebService::NFSN::NFSNError::full_message

#=====================================================================
# Package WebService::NFSN:

sub new
{
  my ($class, $login, $apiKey) = @_;

  # If we didn't get login information, try reading it from .nfsn-api:
  if (@_ == 1) {
    require File::Spec;

    # Try the current directory, then the home directory:
    my $filename = '.nfsn-api';
    $filename = File::Spec->catfile($ENV{HOME}, $filename)
        if (not -e $filename and $ENV{HOME} and -d $ENV{HOME});

    # If we found it, read the file:
    if (not -e $filename) {
      carp("Unable to locate $filename");
    } else {
      # Read in the file:
      local $_;
      open(my $in, '<', $filename) or croak("Can't open $filename: $!");
      my $contents = '';
      $contents .= $_ while <$in>;
      close $in or croak("Error closing $filename: $!");

      # Parse the JSON object:
      my $hashRef = try {
        decode_json($contents)
      } catch {
        croak("Error parsing $filename: $_");
      };

      croak("$filename did not contain a JSON object")
          unless _is_hash($hashRef);

      croak(qq'$filename did not define "login"')
          unless defined ($login  = $hashRef->{login});
      croak(qq'$filename did not define "api-key"')
          unless defined ($apiKey = $hashRef->{'api-key'});
    } # end else -e $filename
  } # end if login & apiKey were not supplied

  # Make sure we have all our parameters:
  croak("You must supply a login")    unless defined $login;
  croak("You must supply an API key") unless defined $apiKey;

  return bless { login => $login,
                 apiKey => $apiKey,
                 url    => 'https://api.nearlyfreespeech.net',
               }, $class;
} # end new

#---------------------------------------------------------------------
BEGIN {
  # Create access methods for each object type:
  #   (Member is not auto-generated, because it has a default value)

  my $code = '';

  foreach my $class (qw(Account DNS Email Site)) {

    my $sub = lc $class;

    $code .= <<"END CHILD CONSTRUCTOR";
sub $sub
{
  require WebService::NFSN::$class;

  WebService::NFSN::$class->new(\@_);
}
END CHILD CONSTRUCTOR

  } # end foreach class

  _eval_or_die $code;
} # end BEGIN

#---------------------------------------------------------------------
sub member
{
  my ($self, $member) = @_;

  require WebService::NFSN::Member;

  WebService::NFSN::Member->new($self, $member || $self->{login});
} # end member

#---------------------------------------------------------------------
sub make_request
{
  my ($self, $req) = @_;

  # Collect member name & request URI:
  my $login = $self->{login};
  my $uri = $req->uri->path;

  # Generate a random 16 character salt value:
  my $salt = join('', map {
    substr($saltAlphabet, int(rand(length $saltAlphabet)), 1)
  } 1 .. 16);

  # Generate the NFSN authentication hash:
  my $body_hash = sha1_hex($req->content);

  my $time = time;

  my $hash = sha1_hex("$login;$time;$salt;$self->{apiKey};$uri;$body_hash");

  $req->header('X-NFSN-Authentication' => "$login;$time;$salt;$hash");

  # Send the request to the NFSN API server:
  my $res = $self->{last_response} = $ua->request($req);

  # Throw an exception if there was an error:
  if ($res->is_error) {
    my $param = try { decode_json($res->content) };

    # Throw NFSNError if we decoded the response successfully:
    if (_is_hash($param) and defined $param->{error}) {
      # If bad timestamp, list the dates:
      my $debug = delete $param->{debug};
      if ($debug and
          $debug eq "The authentication timestamp is out of range.") {
        $debug .= ("\n Client request date:  " . gmtime($time) .
                   "\n Server response date: " . $res->header('Date'));
      } # end if authentication timestamp out of range

      WebService::NFSN::NFSNError->throw(
        error => delete($param->{error}),
        debug => $debug,
        nfsn  => $param,
        request  => $req,
        response => $res,
        @throw_parameters
      );
    } # end if throwing NFSNError

    # Otherwise, throw LWPError:
    WebService::NFSN::LWPError->throw(
      error => sprintf('%s: %s', $res->code, $res->message),
      request  => $req,
      response => $res,
      @throw_parameters
    );
  } # end if error

  # Return the successful response:
  return $res;
} # end make_request

#---------------------------------------------------------------------
sub last_response { $_[0]{last_response} }
sub root_url      { $_[0]{url}           }

#=====================================================================
# Package Return Value:

1;

__END__