File Coverage

blib/lib/XAS/Lib/Curl/HTTP.pm

Criterion	Covered	Total	%
statement	8	11	72.7
branch			n/a
condition			n/a
subroutine	4	5	80.0
pod			n/a
total	12	16	75.0

package XAS::Lib::Curl::HTTP;

our $VERSION = '0.01';

BEGIN {
    no warnings;

    # this constant is not defined in WWW::Curl on RHEL 5,6,7.
    # but is, if you compile libcurl on Windows

    unless (CURLAUTH_ONLY) {

        sub CURLAUTH_ONLY { (1 << 31); } # defined in curl.h

    }

}

use HTTP::Response;
use WWW::Curl::Easy;

use XAS::Class
  debug     => 0,
  version   => $VERSION,
  base      => 'XAS::Base',
  accessors => 'curl',
  mutators  => 'retcode',
  utils     => ':validation dotid',
  vars => {
    PARAMS => {
      -fail_on_error    => { optional => 1, default => 0 },
      -keep_alive       => { optional => 1, default => 1 },
      -follow_location  => { optional => 1, default => 1 },
      -ssl_verify_peer  => { optional => 1, default => 1 },
      -ssl_verify_host  => { optional => 1, default => 1 },
      -max_redirects    => { optional => 1, default => 3 },
      -timeout          => { optional => 1, default => 60 },
      -connect_timeout  => { optional => 1, default => 300 },
      -ssl_cacert       => { optional => 1, default => undef },
      -ssl_keypasswd    => { optional => 1, default => undef },
      -proxy_url        => { optional => 1, default => undef },
      -ssl_cert         => { optional => 1, default => undef, depends => [ 'ssl_key' ] },
      -ssl_key          => { optional => 1, default => undef, depends => [ 'ssl_cert' ] },
      -password         => { optional => 1, default => undef, depends => [ 'username' ] },
      -username         => { optional => 1, default => undef, depends => [ 'password' ] },
      -proxy_password   => { optional => 1, default => undef, depends => [ 'proxy_username' ] },
      -proxy_username   => { optional => 1, default => undef, depends => [ 'proxy_password' ] },
      -auth_method      => { optional => 1, default => 'noauth', regex => qr/any|noauth|basic|digest|ntlm|negotiate/ },
      -proxy_auth       => { optional => 1, default => 'noauth', regex => qr/any|noauth|basic|digest|ntlm|negotiate/ },
    }
  },
;

# ----------------------------------------------------------------------
# Public Methods
# ----------------------------------------------------------------------

sub request {
    my $self = shift;
    my ($request) = validate_params(\@_, [
        { isa => 'HTTP::Request' }
    ]);

    my @head;
    my @buffer;
    my $response = undef;
    my $header   = $request->headers->as_string("\n");
    my @headers  = split("\n", $header);

    $self->curl->setopt(CURLOPT_URL,        $request->uri);
    $self->curl->setopt(CURLOPT_HTTPHEADER, \@headers) if (scalar(@headers));

    # I/O for the request

    $self->curl->setopt(CURLOPT_WRITEDATA,     \@buffer);
    $self->curl->setopt(CURLOPT_HEADERDATA,    \@head);
    $self->curl->setopt(CURLOPT_READFUNCTION,  \&_read_callback);
    $self->curl->setopt(CURLOPT_WRITEFUNCTION, \&_write_callback);

    # other options depending on request type

    if ($request->method eq 'GET') {

        $self->curl->setopt(CURLOPT_HTTPGET, 1);

    } elsif ($request->method eq 'POST') {

        use bytes;

        my $content = $request->content;

        $self->curl->setopt(CURLOPT_POST,           1);
        $self->curl->setopt(CURLOPT_POSTFIELDSIZE,  length($content));
        $self->curl->setopt(CURLOPT_COPYPOSTFIELDS, $content);

    } elsif ($request->method eq 'PUT') {

        use bytes;

        my $content = $request->content;

        $self->curl->setopt(CURLOPT_UPLOAD,     1);
        $self->curl->setopt(CURLOPT_READDATA,   \$content);
        $self->curl->setopt(CURLOPT_INFILESIZE, length($content));

    } elsif ($request->method eq 'HEAD') {

        $self->curl->setopt(CURLOPT_NOBODY, 1);

    } else {

        $self->curl->setopt(CURLOPT_CUSTOMREQUEST, uc $request->method);

    }

    # perform the request and create the response

    if (($self->{'retcode'} = $self->curl->perform) == 0) {

        my @temp;
        my $message;
        my $content;

        # there may be multiple responses within head, we only
        # want the last one. so search backwards until a HTTP header
        # is found.

        while (my $line = pop(@buffer)) {

            push(@temp, $line);
            last if ($line =~ /^HTTP\//);

        }

        $content = join('', reverse(@temp));

        # now let HTTP::Response figure it all out...

        $response = HTTP::Response->parse($content);

        # do some fixups

        $message = $response->message;
        $response->message($message) if ($message =~ s/\r//g);
        $response->request($request);

    } else {

        $self->throw_msg(
            dotid($self->class) . '.request.curl',
            'curl',
            $self->retcode, lc($self->curl->strerror($self->retcode))
        );

    }

    return $response;

}

# ----------------------------------------------------------------------
# Private Methods
# ----------------------------------------------------------------------

sub _read_callback {
    my ($maxlength, $pointer) = @_;

    my $data = substr($$pointer, 0, $maxlength);

    $$pointer =
      length($$pointer) > $maxlength
      ? scalar substr($$pointer, $maxlength)
      : '';

    return $data;

}

sub _write_callback {
    my ($data, $pointer) = @_;

    push(@{$pointer}, $data);

    return length($data);

}

sub _authentication {
    my $self = shift;

    my $authen = 0;

    # setup authentication

    $authen = CURLAUTH_ANY                          if ($self->auth_method eq 'any');
    $authen = CURLAUTH_NTLM         | CURLAUTH_ONLY if ($self->auth_method eq 'ntlm');
    $authen = CURLAUTH_BASIC        | CURLAUTH_ONLY if ($self->auth_method eq 'basic');
    $authen = CURLAUTH_DIGEST       | CURLAUTH_ONLY if ($self->auth_method eq 'digest');
    $authen = CURLAUTH_GSSNEGOTIATE | CURLAUTH_ONLY if ($self->auth_method eq 'negotitate');

    return $authen;

}

sub init {
    my $class = shift;

    my $self = $class->SUPER::init(@_);

    my $authen          = 0;
    my $timeout         = $self->timeout * 1000;
    my $protocols       = (CURLPROTO_HTTP & CURLPROTO_HTTPS);
    my $connect_timeout = $self->timeout * 1000;

    $self->{curl} = WWW::Curl::Easy->new();

    # basic options

    $self->curl->setopt(CURLOPT_HEADER,            0);
    $self->curl->setopt(CURLOPT_VERBOSE,           $self->xdebug);
    $self->curl->setopt(CURLOPT_MAXREDIRS,         $self->max_redirects);
    $self->curl->setopt(CURLOPT_PROTOCOLS,         $protocols);
    $self->curl->setopt(CURLOPT_NOPROGRESS,        1);
    $self->curl->setopt(CURLOPT_TIMEOUT_MS,        $timeout);
    $self->curl->setopt(CURLOPT_FAILONERROR,       $self->fail_on_error);
    $self->curl->setopt(CURLOPT_FORBID_REUSE,      $self->keep_alive);
    $self->curl->setopt(CURLOPT_FOLLOWLOCATION,    $self->follow_location);
    $self->curl->setopt(CURLOPT_CONNECTTIMEOUT_MS, $connect_timeout);

    # setup authentication

    $authen = $self->_authentication();
    $self->curl->setopt(CURLOPT_HTTPAUTH, $authen);

    if ($self->username) {

        $self->curl->setopt(CURLOPT_USERNAME, $self->username);
        $self->curl->setopt(CURLOPT_PASSWORD, $self->password);

    }

    # setup proxy stuff

    if ($self->proxy_url) {

        $authen = $self->_authentication();

        $self->curl->setopt(CURLOPT_PROXY,         $self->proxy_url);
        $self->curl->setopt(CURLOPT_PROXYAUTH,     $authen);
        $self->curl->setopt(CURLOPT_PROXYUSERNAME, $self->proxy_username);
        $self->curl->setopt(CURLOPT_PROXYPASSWORD, $self->proxy_password);

    }

    # set up the SSL stuff

    $self->curl->setopt(CURLOPT_SSL_VERIFYPEER, $self->ssl_verify_peer);
    $self->curl->setopt(CURLOPT_SSL_VERIFYHOST, $self->ssl_verify_host);

    if ($self->ssl_keypasswd) {

        $self->curl->setop(CURLOPT_KEYPASSWD, $self->ssl_keypasswd);

    }

    if ($self->ssl_cacert) {

        $self->curl->setopt(CURLOPT_CAINFO, $self->ssl_cacert);

    }

    if ($self->ssl_cert) {

        $self->curl->setopt(CURLOPT_SSLCERT, $self->ssl_cert);
        $self->curl->setopt(CURLOPT_SSLKEY,  $self->ssl_key);

    }

    return $self;

}

1;

__END__