package Web::API;

use 5.010;
use Mouse::Role;

# ABSTRACT: Web::API - A Simple base module to implement almost every RESTful API with just a few lines of configuration

our $VERSION = '1.3'; # VERSION

use LWP::UserAgent;
use HTTP::Cookies;
use Data::Dump 'dump';
use XML::Simple;
use URI::Escape::XS qw/uri_escape uri_unescape/;
use JSON;
use URI;
use URI::QueryParam;
use Carp;
use Net::OAuth;
use Data::Random qw(rand_chars);

$Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0A;

our $AUTOLOAD;


requires 'commands';


has 'base_url' => (
    is  => 'rw',
    isa => 'Str',
);


has 'api_key' => (
    is       => 'rw',
    isa      => 'Str',
    required => 1,
);


has 'user' => (
    is  => 'rw',
    isa => 'Str',
);


has 'api_key_field' => (
    is      => 'rw',
    isa     => 'Str',
    default => sub { 'key' },
);


has 'mapping' => (
    is      => 'rw',
    default => sub { {} },
);


has 'wrapper' => (
    is      => 'rw',
    clearer => 'clear_wrapper',
);


has 'header' => (
    is      => 'rw',
    lazy    => 1,
    default => sub { {} },
);


has 'auth_type' => (
    is      => 'rw',
    isa     => 'Str',
    default => sub { 'none' },
);


has 'default_method' => (
    is      => 'rw',
    isa     => 'Str',
    default => sub { 'GET' },
);


has 'extension' => (
    is  => 'rw',
    isa => 'Str',
);


has 'user_agent' => (
    is      => 'rw',
    isa     => 'Str',
    default => sub { __PACKAGE__ . ' ' . $Web::API::VERSION },
);


has 'timeout' => (
    is       => 'rw',
    isa      => 'Int',
    default  => sub { 30 },
    required => 1,
);


has 'strict_ssl' => (
    is       => 'rw',
    isa      => 'Bool',
    default  => sub { 0 },
    lazy     => 1,
    required => 1,
);


has 'agent' => (
    is       => 'rw',
    isa      => 'LWP::UserAgent',
    lazy     => 1,
    required => 1,
    builder  => '_build_agent',
);


has 'content_type' => (
    is      => 'rw',
    isa     => 'Str',
    default => sub { 'text/plain' },
);


has 'incoming_content_type' => (
    is  => 'rw',
    isa => 'Str',
);


has 'outgoing_content_type' => (
    is  => 'rw',
    isa => 'Str',
);


has 'debug' => (
    is      => 'rw',
    isa     => 'Bool',
    default => sub { 0 },
    lazy    => 1,
);


has 'cookies' => (
    is      => 'rw',
    isa     => 'HTTP::Cookies',
    default => sub { HTTP::Cookies->new },
);


has 'consumer_secret' => (
    is  => 'rw',
    isa => 'Str',
);


has 'access_token' => (
    is  => 'rw',
    isa => 'Str',
);


has 'access_secret' => (
    is  => 'rw',
    isa => 'Str',
);


has 'signature_method' => (
    is      => 'rw',
    isa     => 'Str',
    default => sub { 'HMAC-SHA1' },
    lazy    => 1,
);


has 'oauth_post_body' => (
    is      => 'rw',
    isa     => 'Bool',
    default => sub { 1 },
    lazy    => 1,
);

has 'json' => (
    is      => 'rw',
    isa     => 'JSON',
    default => sub {
        my $js = JSON->new;
        $js->utf8;
        $js->allow_blessed;
        $js->convert_blessed;
        $js->allow_nonref;
        $js;
    },
);

has 'xml' => (
    is      => 'rw',
    isa     => 'XML::Simple',
    lazy    => 1,
    default => sub {
        XML::Simple->new(
            ContentKey => '-content',
            NoAttr     => 1,
            KeepRoot   => 1,
            KeyAttr    => {},
        );
    },
);

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

    return LWP::UserAgent->new(
        agent      => $self->user_agent,
        cookie_jar => $self->cookies,
        timeout    => $self->timeout,
        ssl_opts   => { verify_hostname => $self->strict_ssl },
    );
}


sub nonce {
    return join('', rand_chars(size => 16, set => 'alphanumeric'));
}


sub log {    ## no critic (ProhibitBuiltinHomonyms)
    my ($self, $msg) = @_;
    print STDERR __PACKAGE__ . ': ' . $msg . $/;
    return;
}


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

    my $data;
    eval {
        given ($content_type)
        {
            when (/text/) { $data = $content; }
            when (/urlencoded/) {
                foreach (split(/&/, $content)) {
                    my ($key, $value) = split(/=/, $_);
                    $data->{ uri_unescape($key) } = uri_unescape($value);
                }
            }
            when (/json/) { $data = $self->json->decode($content); }
            when (/xml/) { $data = $self->xml->XMLin($content, NoAttr => 0); }
        }
    };
    return { error => "couldn't decode payload using $content_type: $@\n"
            . dump($content) }
        if ($@ || ref \$content ne 'SCALAR');

    return $data;
}


sub encode {
    my ($self, $options, $content_type) = @_;

    my $payload;
    eval {
        given ($content_type)
        {
            when (/text/) { $payload = $options; }
            when (/urlencoded/) {
                $payload .=
                    uri_escape($_) . '=' . uri_escape($options->{$_}) . '&'
                    foreach (keys %$options);
                chop($payload);
            }
            when (/json/) { $payload = $self->json->encode($options); }
            when (/xml/)  { $payload = $self->xml->XMLout($options); }
        }
    };
    return { error => "couldn't encode payload using $content_type: $@\n"
            . dump($options) }
        if ($@ || ref \$payload ne 'SCALAR');

    return $payload;
}


sub talk {
    my ($self, $command, $uri, $options, $content_type) = @_;

    my $method = uc($command->{method} || $self->default_method);
    my $oauth_req;

    # handle different auth_types
    given (lc $self->auth_type) {
        when ('basic') { $uri->userinfo($self->user . ':' . $self->api_key); }
        when ('hash_key') {
            $options->{ $self->api_key_field } = $self->api_key;
        }
        when ('get_params') {
            $uri->query_form(
                $self->mapping->{user}    || 'user'    => $self->user,
                $self->mapping->{api_key} || 'api_key' => $self->api_key,
            );
        }
        when (/^oauth/) {
            my %opts = (
                consumer_key     => $self->api_key,
                consumer_secret  => $self->consumer_secret,
                request_url      => $uri,
                request_method   => $method,
                signature_method => $self->signature_method,
                timestamp        => time,
                nonce            => $self->nonce,
                token            => $self->access_token,
                token_secret     => $self->access_secret,
            );

            if (
                $options
                and (($self->oauth_post_body and $method eq 'POST')
                    or $method ne 'POST'))
            {
                $opts{extra_params} = $options;
            }

            $oauth_req = Net::OAuth->request("protected resource")->new(%opts);
            $oauth_req->sign;
        }
        default {
            $self->log(
                "WARNING: auth_type " . $self->auth_type . " not supported yet")
                unless (lc($self->auth_type) eq 'none');
        }
    }

    # encode payload
    my $payload;
    if (keys %$options) {
        if ($method =~ m/^(GET|HEAD|DELETE)$/) {

            # TODO: check whether $option is a flat hashref

            unless ($self->auth_type eq 'oauth_params') {
                $uri->query_param_append($_ => $options->{$_})
                    for (keys %$options);
            }
        }
        else {
            $payload = $self->encode($options, $content_type->{out});

            # got an error while encoding? return it
            return $payload
                if (ref $payload eq 'HASH' && exists $payload->{error});

            $self->log("send payload: $payload") if $self->debug;
        }
    }

    $uri = $oauth_req->to_url if ($self->auth_type eq 'oauth_params');

    # build headers
    my %header;
    if (exists $command->{headers} and ref $command->{headers} eq 'HASH') {
        %header = (%{ $self->header }, %{ $command->{headers} });
    }
    else {
        %header = %{ $self->header };
    }
    my $headers = HTTP::Headers->new(%header, "Accept" => $content_type->{in});

    if ($self->debug) {
        $self->log("uri: $method $uri");
        $self->log("extra headers:\n" . dump(\%header)) if (%header);
        $self->log("OAuth headers:\n" . $oauth_req->to_authorization_header)
            if ($self->auth_type eq 'oauth_header');
    }

    # build request
    my $request = HTTP::Request->new($method, $uri, $headers);
    unless ($method =~ m/^(GET|HEAD|DELETE)$/) {
        $request->header("Content-type" => $content_type->{out});
        $request->content($payload);
    }

    # oauth POST
    if (    $options
        and ($method eq 'POST')
        and ($self->auth_type =~ m/^oauth/)
        and $self->oauth_post_body)
    {
        $request->content($oauth_req->to_post_body);
    }

    # oauth_header
    $request->header(Authorization => $oauth_req->to_authorization_header)
        if ($self->auth_type eq 'oauth_header');

    # do the actual work
    $self->agent->cookie_jar($self->cookies);
    my $response = $self->agent->request($request);

    $self->log("recv payload: " . $response->decoded_content)
        if $self->debug;

    # collect response headers
    my $response_headers;
    $response_headers->{$_} = $response->header($_)
        foreach ($response->header_field_names);

    my $answer = {
        header => $response_headers,
        code   => $response->code,
        content =>
            $self->decode($response->decoded_content, $content_type->{in}),
        raw => $response->content,
    };

    unless ($response->is_success || $response->is_redirect) {
        $self->log("error: "
                . $response->status_line
                . $/
                . "message: "
                . $response->decoded_content)
            if $self->debug;

        $answer->{error} = "request failed: " . $response->status_line;
    }

    return $answer;
}


sub map_options {
    my ($self, $options, $command, $content_type) = @_;

    my $method = uc($command->{method} || $self->default_method);

    # check existence of mandatory attributes
    if ($command->{mandatory}) {
        $self->log("mandatory keys:\n" . dump(\@{ $command->{mandatory} }))
            if $self->debug;

        my @missing_attrs;
        foreach my $attr (@{ $command->{mandatory} }) {
            push(@missing_attrs, $attr) unless (exists $options->{$attr});
        }

        return { error => 'mandatory attributes for this command missing: '
                . join(', ', @missing_attrs) }
            if @missing_attrs;
    }

    my %opts;

    # first include assumed to be already mapped default attributes
    %opts = %{ $command->{default_attributes} }
        if exists $command->{default_attributes};

    # then map everything in $options, overwriting detault_attributes if necessary
    if (keys %{ $self->mapping } and not $command->{no_mapping}) {
        $self->log("mapping hash:\n" . dump($self->mapping)) if $self->debug;

        # do the key and value mapping of options hash and overwrite defaults
        foreach my $key (keys %$options) {
            my ($newkey, $newvalue);
            $newkey = $self->mapping->{$key} if ($self->mapping->{$key});
            $newvalue = $self->mapping->{ $options->{$key} }
                if ($self->mapping->{ $options->{$key} });

            $opts{ $newkey || $key } = $newvalue || $options->{$key};
        }

        # and write everything back to $options
        $options = \%opts;
    }
    else {
        $options = { %opts, %$options };
    }

    # wrap all options in wrapper key(s) if requested
    $options =
        wrap($options, $command->{wrapper} || $self->wrapper, $content_type)
        unless ($method =~ m/^(GET|HEAD|DELETE)$/);

    $self->log("options:\n" . dump($options)) if $self->debug;

    return $options;
}


sub wrap {
    my ($options, $wrapper, $content_type) = @_;

    if (ref $wrapper eq 'ARRAY') {

        # XML needs wrapping into extra array ref layer to make XML::Simple
        # behave correctly
        if ($content_type =~ m/xml/) {
            $options = { $_ => [$options] } for (reverse @{$wrapper});
        }
        else {
            $options = { $_ => $options } for (reverse @{$wrapper});
        }
    }
    elsif (defined $wrapper) {
        $options = { $wrapper => $options };
    }

    return $options;
}


sub AUTOLOAD {
    my ($self, %options) = @_;

    my ($command) = $AUTOLOAD =~ /([^:]+)$/;

    return { error => "unknown command: $command" }
        unless (exists $self->commands->{$command});

    my $options = \%options;

    # construct URI path
    my $uri  = URI->new($self->base_url);
    my $path = $uri->path;

    # keep for backward compatibility
    if ($self->commands->{$command}->{require_id}) {
        return { error => "required {id} attribute missing" }
            unless (exists $options->{id});
        my $id = delete $options->{id};
        $path .= '/' . $self->commands->{$command}->{pre_id_path}
            if (exists $self->commands->{$command}->{pre_id_path});
        $path .= '/' . $id;
        $path .= '/' . $self->commands->{$command}->{post_id_path}
            if (exists $self->commands->{$command}->{post_id_path});
    }
    elsif (exists $self->commands->{$command}->{path}) {
        $path .= '/' . $self->commands->{$command}->{path};

        # parse all mandatory ID keys from URI path
        # format: /path/with/some/:id/and/:another_id/fun.js
        my @mandatory = ($self->commands->{$command}->{path} =~ m/:(\w+)/g);

        # and replace placeholders
        foreach my $key (@mandatory) {
            return { error => "required {$key} attribute missing" }
                unless exists $options->{$key};

            my $encoded_option = uri_escape(delete $options->{$key});
            $path =~ s/:$key/$encoded_option/gex;
        }
    }
    else {
        $path .= "/$command";
    }

    $path .= '.' . $self->extension if (defined $self->extension);
    $uri->path($path);

    # configure in/out content types
    my $content_type;
    $content_type->{in} =
           $self->commands->{$command}->{incoming_content_type}
        || $self->commands->{$command}->{content_type}
        || $self->incoming_content_type
        || $self->content_type;
    $content_type->{out} =
           $self->commands->{$command}->{outgoing_content_type}
        || $self->commands->{$command}->{content_type}
        || $self->outgoing_content_type
        || $self->content_type;

    # manage options
    $options = $self->map_options($options, $self->commands->{$command},
        $content_type->{in})
        if ((
                (keys %$options)
            and ($content_type->{out} =~ m/(xml|json|urlencoded)/))
        or (exists $self->commands->{$command}->{default_attributes})
        or (exists $self->commands->{$command}->{mandatory}));
    return $options if (exists $options->{error});

    # do the call
    my $response =
        $self->talk($self->commands->{$command}, $uri, $options, $content_type);

    $self->log("response:\n" . dump($response)) if $self->debug;

    return $response;
}


1;    # End of Web::API

__END__

=pod

=head1 NAME

Web::API - Web::API - A Simple base module to implement almost every RESTful API with just a few lines of configuration

=head1 VERSION

version 1.3

=head1 SYNOPSIS

Implement the RESTful API of your choice in 10 minutes, roughly.

    package Net::CloudProvider;

    use Any::Moose;
    with 'Web::API';

    our $VERSION = "0.1";

    has 'commands' => (
        is      => 'rw',
        default => sub {
            {
                list_nodes => { method => 'GET' },
                node_info  => { method => 'GET', require_id => 1 },
                create_node => {
                    method             => 'POST',
                    default_attributes => {
                        allowed_hot_migrate            => 1,
                        required_virtual_machine_build => 1,
                        cpu_shares                     => 5,
                        required_ip_address_assignment => 1,
                        primary_network_id             => 1,
                        required_automatic_backup      => 0,
                        swap_disk_size                 => 1,
                    },
                    mandatory => [
                        'label',
                        'hostname',
                        'template_id',
                        'cpus',
                        'memory',
                        'primary_disk_size',
                        'required_virtual_machine_build',
                        'cpu_shares',
                        'primary_network_id',
                        'required_ip_address_assignment',
                        'required_automatic_backup',
                        'swap_disk_size',
                    ]
                },
                update_node => { method => 'PUT',    require_id => 1 },
                delete_node => { method => 'DELETE', require_id => 1 },
                start_node  => {
                    method       => 'POST',
                    require_id   => 1,
                    post_id_path => 'startup',
                },
                stop_node => {
                    method       => 'POST',
                    require_id   => 1,
                    post_id_path => 'shutdown',
                },
                suspend_node => {
                    method       => 'POST',
                    require_id   => 1,
                    post_id_path => 'suspend',
                },
            };
        },
    );

    sub commands {
        my ($self) = @_;
        return $self->commands;
    }

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

        $self->user_agent(__PACKAGE__ . ' ' . $VERSION);
        $self->base_url('https://ams01.cloudprovider.net/virtual_machines');
        $self->content_type('application/json');
        $self->extension('json');
        $self->wrapper('virtual_machine');
        $self->mapping({
                os        => 'template_id',
                debian    => 1,
                id        => 'label',
                disk_size => 'primary_disk_size',
        });

        return $self;
    }

    1;

later use as:

    use Net::CloudProvider;
    
    my $nc = Net::CloudProvider(user => 'foobar', api_key => 'secret');
    my $response = $nc->create_node({
        id                             => 'funnybox',
        hostname                       => 'node.funnybox.com',
        os                             => 'debian',
        cpus                           => 2,
        memory                         => 256,
        disk_size                      => 5,
        allowed_hot_migrate            => 1,
        required_virtual_machine_build => 1,
        cpu_shares                     => 5,
        required_ip_address_assignment => 1,
    });

=head1 ATTRIBUTES

=head2 commands

most important configuration part of the module which has to be provided by the
module you are writing.

the following keys are valid/possible:

    method
    require_id
    path
    pre_id_path
    post_id_path
    wrapper
    default_attributes
    mandatory
    extension
    content_type
    incoming_content_type
    outgoing_content_type

the request path for non require_id commands is being build as:

    $base_url/$path.$extension

accordingly requests with require_id:

    $base_url/$pre_id_path/$id/$post_id_path.$extension

whereas $id can be any arbitrary object like a domain, that the API in question
does operations on.

=head2 base_url (required)

get/set base URL to API, can include paths

=head2 api_key (required)

get/set api_key

=head2 user (optional)

get/set username/account name

=head2 api_key_field (optional)

get/set name of the hash key in the POST data structure that has to hold the api_key

=head2 mapping (optional)

supply mapping table, hashref of format { key => value }

default: undef

=head2 wrapper (optional)

=head2 header (optional)

get/set custom headers sent with each request

=head2

get/set authentication type. currently supported are only 'basic', 'hash_key', 'get_params', 'oauth_header', 'oauth_params' or 'none'

default: none

=head2 default_method (optional)

get/set default HTTP method

default: GET

=head2 extension (optional)

get/set file extension, e.g. '.json'

=head2 user_agent (optional)

get/set User Agent String

default: "Web::API $VERSION"

=head2 timeout (optional)

get/set LWP::UserAgent timeout

=head2 strict_ssl (optional)

enable/disable strict SSL certificate hostname checking

default: false

=head2 agent (optional)

get/set LWP::UserAgent object

=head2 content_type (optional)

default: 'text/plain'

=head2 incoming_content_type (optional)

default: undef

=head2 outgoing_content_type (optional)

default: undef

=head2 debug (optional)

default: 0

=head2 cookies (optional)

default: HTTP::Cookies->new

=head2 consumer_secret (required for all oauth_* auth_types)

default: undef

=head2 access_token (required for all oauth_* auth_types)

default: undef

=head2 access_secret (required for all oauth_* auth_types)

default: undef

=head2 signature_method (required for all oauth_* auth_types)

default: undef

=head2 oauth_post_body (required for all oauth_* auth_types)

default: true

=head1 INTERNAL SUBROUTINES/METHODS

=head2 nonce

generates new OAuth nonce for every request

=head2 log

=head2 decode

=head2 encode

=head2 talk

=head2 map_options

=head2 wrap

=head2 AUTOLOAD magic

=head1 BUGS

Please report any bugs or feature requests on GitHub's issue tracker L<https://github.com/nupfel/Web-API/issues>.
Pull requests welcome.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Web::API

You can also look for information at:

=over 4

=item * GitHub repository

L<https://github.com/nupfel/Web-API>

=item * MetaCPAN

L<https://metacpan.org/module/Web::API>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Web::API>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Web::API>

=back

=head1 AUTHOR

Tobias Kirschstein <lev@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2013 by Tobias Kirschstein.

This is free software, licensed under:

  The (three-clause) BSD License

=cut
