package RPC::ExtDirect::Client;

use strict;
use warnings;
no  warnings 'uninitialized';

use File::Spec;
use HTTP::Tiny;

use RPC::ExtDirect::Client::API;

### VERSION ###

our $VERSION = '0.22';

### PUBLIC CLASS METHOD (CONSTRUCTOR) ###
#
# Instantiate a new Client, connect to specified server
# and initialize Ext.Direct API
#

sub new {
    my ($class, %params) = @_;

    my @our_params = qw(
        host port api_path router_path poll_path
        remoting_var polling_var
    );

    my $self = bless { tid => 0 }, $class;

    @$self{ @our_params } = delete @params{ @our_params };

    # Reasonable defaults
    $self->{api_path}     ||= '/api';
    $self->{router_path}  ||= '/router';
    $self->{poll_path}    ||= '/events';
    $self->{remoting_var} ||= 'Ext.app.REMOTING_API';
    $self->{polling_var}  ||= 'Ext.app.POLLING_API';

    # The rest of parameters apply to transport
    $self->{http_params} = { %params };

    my $api_js = $self->_get_api();
    $self->_import_api($api_js);

    return $self;
}

### PUBLIC INSTANCE METHOD ###
#
# Call specified Action's Method
#

sub call {
    my ($self, %params) = @_;

    my $action = delete $params{action};
    my $method = delete $params{method};
    my $arg    = delete $params{arg};

    my $actual_arg = $self->_normalize_arg($action, $method, $arg);

    my $response = $self->_call_sync($action, $method, $actual_arg, \%params);

    # We're only interested in the data
    return ref($response) =~ /Exception/ ? $response
         :                                 $response->{result}
         ;
}

### PUBLIC INSTANCE METHOD ###
#
# Submit a form to specified Action's Method
#

sub submit {
    my ($self, %params) = @_;

    # Form calls do not support batching
    my $response = $self->_call_form(%params);

    # We're only interested in the data
    return ref($response) =~ /Exception/ ? $response
         :                                 $response->{result}
         ;
}

### PUBLIC INSTANCE METHOD ###
#
# Upload a file using POST form. Same as submit()
#

*upload = *submit;

### PUBLIC INSTANCE METHOD ###
#
# Poll server for Ext.Direct events
#

sub poll {
    my ($self, %params) = @_;

    my $response = $self->_call_poll(%params);

    return $response;
}

### PUBLIC INSTANCE METHOD ###
#
# Return next TID (transaction ID)
#

sub next_tid { $_[0]->{tid}++ }

### PUBLIC INSTANCE METHOD ###
#
# Read only getter
#

sub api { $_[0]->{api} }

############## PRIVATE METHODS BELOW ##############

### PRIVATE INSTANCE METHOD ###
#
# Receive API declaration from specified server,
# parse it and return Client::API object
#

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

    my $uri    = $self->_get_uri('api');
    my $params = $self->{http_params};

    my $resp = HTTP::Tiny->new(%$params)->get($uri);

    die "Can't download API declaration: $resp->{status}\n"
        unless $resp->{success};

    die "Empty API declaration\n"
        unless length $resp->{content};

    return $resp->{content};
}

### PRIVATE INSTANCE METHOD ###
#
# Return URI for specified type of call
#

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

    my $host = $self->{host};
    my $port = $self->{port};

    my $path = $type eq 'api'    ? $self->{api_path}
             : $type eq 'router' ? $self->{router_path}
             : $type eq 'poll'   ? $self->{poll_path}
             :                     die "Unknown type $type\n"
             ;

    $path   =~ s{^/}{};

    my $uri  = $port ? "http://$host:$port/$path"
             :         "http://$host/$path"
             ;

    return $uri;
}

### PRIVATE INSTANCE METHOD ###
#
# Import specified API into global namespace
#

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

    # Readability shortcut
    my $aclass = 'RPC::ExtDirect::Client::API';

    my $api = $aclass->new($api_js);

    $self->{api} = $api;
}

### PRIVATE INSTANCE METHOD ###
#
# Normalize passed arguments to conform to Method's spec
#

sub _normalize_arg {
    my ($self, $action, $method, $arg) = @_;

    my $named   = $self->api->actions($action)->method($method)->is_named;
    my $ordered = $self->api->actions($action)->method($method)->is_ordered;

    die "${action}->$method requires ordered (by position) arguments\n"
        if $ordered and 'ARRAY' ne ref $arg;

    die "${action}->$method requires named arguments\n"
        if $named and 'HASH' ne ref $arg;

    my $result;

    if ( $named ) {
        my $params = $self->api->actions($action)->method($method)->params;

        @$result{ @$params } = @$arg{ @$params };
    }
    elsif ( $ordered ) {
        my $len = $self->api->actions($action)->method($method)->len;

        @$result = splice @$arg, 0, $len;
    }
    else {
        $result = $arg;
    }

    return $result;
}

### PRIVATE INSTANCE METHOD ###
#
# Normalize passed arguments to submit as form POST
#

sub _formalize_arg {
    my ($self, %params) = @_;

    my $action = $params{action};
    my $method = $params{method};
    my $arg    = $params{arg};
    my $upload = $params{upload};

    my $fields = {
        extAction => $action,
        extMethod => $method,
        extType   => 'rpc',
        extTID    => $self->next_tid,
    };

    $fields->{extUpload} = 'true' if $upload;

    @$fields{ keys %$arg } = values %$arg;

    return $fields;
}

### PRIVATE INSTANCE METHOD ###
#
# Calls Action's Method in synchronous fashion
#

sub _call_sync {
    my ($self, $action, $method, $arg, $p) = @_;

    my $uri       = $self->_get_uri('router');
    my $params    = $self->{http_params} || {};
    my $post_body = $self->_encode_post_body($action, $method, $arg);

    @$params{ keys %$p } = values %$p if $p;

    my $options = {
        content => $post_body,
    };

    $self->_parse_cookies($options, $params);

    my $transp = HTTP::Tiny->new(%$params);
    my $resp   = $transp->post($uri, $options);

    return $self->_handle_response($resp);
}

### PRIVATE INSTANCE METHOD ###
#
# Call Action's Method by submitting a form
#

sub _call_form {
    my ($self, %params) = @_;

    my $uri    = $self->_get_uri('router');
    my $fields = $self->_formalize_arg(%params);
    my $upload = $params{upload};

    my $ct = $upload ? 'multipart/form-data; boundary='.$self->_get_boundary
           :           'application/x-www-form-urlencoded; charset=utf-8'
           ;
    my $form_body = $upload ? $self->_www_form_multipart($fields, $upload)
                  :           $self->_www_form_urlencode($fields)
                  ;

    my $options = {
        headers => {
            'Content-Type' => $ct,
        },
        content => $form_body,
    };

    my $p = $self->{http_params} || {};
    @$p{ keys %params } = values %params;

    $self->_parse_cookies($options, $p);

    my $resp = HTTP::Tiny->new->post($uri, $options);

    return $self->_handle_response($resp);
}

### PRIVATE INSTANCE METHOD ###
#
# Call Ext.Direct polling provider
#

sub _call_poll {
    my ($self, %params) = @_;

    my $uri = $self->_get_uri('poll');

    my $options = {};

    my $p = $self->{http_params} || {};
    @$p{ keys %params } = values %params;

    $self->_parse_cookies($options, $p);

    my $resp = HTTP::Tiny->new->get($uri, $options);

    return $self->_handle_poll_response($resp);
}

### PRIVATE INSTANCE METHOD ###
#
# Create POST payload body
#

sub _encode_post_body {
    my ($self, $action, $method, $arg) = @_;

    my $href = {
        action => $action,
        method => $method,
        data   => $arg,
        type   => 'rpc',
        tid    => $self->next_tid,
    };

    return JSON->new->utf8(1)->encode($href);
}

### PRIVATE INSTANCE METHOD ###
#
# Encode form fields as multipart/form-data
#

sub _www_form_multipart {
    my ($self, $arg, $uploads) = @_;

    # This code is shamelessly "adapted" from CGI::Test::Input::Multipart
    my $CRLF     = "\015\012";
    my $boundary = '--' . $self->_get_boundary();
    my $format   = 'Content-Disposition: form-data; name="%s"';

    my $result;

    while ( my ($field, $value) = each %$arg ) {
        $result .= $boundary                . $CRLF;
        $result .= sprintf($format, $field) . $CRLF.$CRLF;
        $result .= $value                   . $CRLF;
    };

    while ( $uploads && @$uploads ) {
        my $filename = shift @$uploads;
        my $basename = (File::Spec->splitpath($filename))[2];

        $result .= $boundary                                . $CRLF;
        $result .= sprintf $format, 'upload';
        $result .= sprintf('; filename="%s"', $basename)    . $CRLF;
        $result .= "Content-Type: application/octet-stream" . $CRLF.$CRLF;

        if ( open my $fh, '<', $filename ) {
            binmode $fh;
            local $/;

            $result .= <$fh> . $CRLF;
        };
    }

    $result .= $boundary . '--' if $result;

    return $result;
}

### PRIVATE INSTANCE METHOD ###
#
# Generate multipart/form-data boundary
#

my $boundary;

sub _get_boundary {
    return $boundary if $boundary;
    
    my $rand;

    for ( 0..19 ) {
        $rand .= (0..9, 'A'..'Z')[$_] for int rand 36;
    };

    return $boundary = $rand;
}

### PRIVATE INSTANCE METHOD ###
#
# Encode form fields as application/x-www-form-urlencoded
#

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

    return HTTP::Tiny->new->www_form_urlencode($arg);
}

### PRIVATE INSTANCE METHOD ###
#
# Process Ext.Direct response and return either data or exception
#

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

    # By Ext.Direct spec it shouldn't even happen, but then again
    die "Ext.Direct request unsuccessful: $resp->{status}\n"
        unless $resp->{success};

    my $exclass = 'RPC::ExtDirect::Client::Exception';

    if ( $resp->{status} == 599 ) {

        # This means internal HTTP::Tiny error
        return $exclass->new({ type    => 'exception',
                               message => $resp->{content},
                               where   => 'HTTP::Tiny',
                            });
    };

    my $content = $self->_decode_response_body( $resp->{content} );

    return $exclass->new($content)
        if 'HASH' eq ref $content and $content->{type} eq 'exception';

    return $content;
}

### PRIVATE INSTANCE METHOD ###
#
# Handle poll response
#

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

    my $ev = $self->_decode_response_body( $resp->{content} );

    # Poll provider has to return a null event if there are no events
    # because returning empty response would break JavaScript client.
    # But we don't have to follow that broken implementation here.
    return
        if ('HASH' ne ref $ev and 'ARRAY' ne ref $ev) or
           ('HASH' eq ref $ev and
                ($ev->{name} eq '__NONE__' or $ev->{name} eq '' or
                 $ev->{type} ne 'event')
           )
        ;

    delete $_->{type} for 'ARRAY' eq ref $ev ? @$ev : ( $ev );

    return $ev;
}

### PRIVATE INSTANCE METHOD ###
#
# Decode Ext.Direct response body
#

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

    my $json_text = $body;

    # Form POSTs require this additional handling
    my $re = qr{^<html><body><textarea>(.*)</textarea></body></html>$}msi;

    if ( $body =~ $re ) {
        $json_text = $1;
        $json_text =~ s{\\"}{"}g;
    };

    return JSON->new->utf8(1)->decode($json_text);
}

### PRIVATE INSTANCE METHOD ###
#
# Parse cookies if provided, creating Cookie headers
#

sub _parse_cookies {
    my ($self, $to, $from) = @_;

    my $cookie_jar = $from->{cookies};

    return unless $cookie_jar;

    my $cookies;

    if ( 'HTTP::Cookies' eq ref $cookie_jar ) {
        $cookies = $self->_parse_http_cookies($cookie_jar);
    }
    else {
        $cookies = $self->_parse_raw_cookies($cookie_jar);
    }

    $to->{headers}->{Cookie} = $cookies if $cookies;
}

### PRIVATE INSTANCE METHOD ###
#
# Parse cookies from HTTP::Cookies object
#

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

    my @cookies;

    $cookie_jar->scan(sub {
        my ($v, $key, $value) = @_;

        push @cookies, "$key=$value";
    });

    return \@cookies;
}

### PRIVATE INSTANCE METHOD ###
#
# Parse (or rather, normalize) cookies passed as a hashref
#

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

    return [] unless 'HASH' eq ref $cookie_jar;

    return [ map { join '=', $_ => $cookie_jar->{$_} } keys %$cookie_jar ];
}

# Tiny helper class
package
    RPC::ExtDirect::Client::Exception;

use overload
    '""' => \&stringify
    ;

### PUBLIC CLASS METHOD (CONSTRUCTOR) ###
#
# Instantiate a new Exception
#

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

    return bless $ex, $class;
}

### PUBLIC INSTANCE METHOD ###
#
# Return stringified Exception
#

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

    return sprintf "Exception %s in %s",
                   $self->{message}, $self->{where};
}

1;

__END__

=pod

=head1 NAME

RPC::ExtDirect::Client - Ext.Direct client in Perl

=head1 SYNOPSIS

 use RPC::ExtDirect::Client;
 
 my $client = RPC::ExtDirect::Client->new(host => 'localhost');
 my $result = $client->call(
    action  => 'Action',
    method  => 'Method',
    arg     => [ 'foo', 'bar' ],
    cookies => { foo => 'bar' },
 );

=head1 DESCRIPTION

This module implements Ext.Direct client in pure Perl. Its main purpose
is to be used for testing server side Ext.Direct classes.

RPC::ExtDirect::Client uses HTTP::Tiny as transport.

=head1 METHODS

=over 4

=item new(%params)

Creates a new client instance. Constructor accepts the following arguments:

=over 8

=item api_path

URI for Ext.Direct API published by server. Default: '/api'.

=item router_path

URI for Ext.Direct remoting requests. Default: '/router'.

=item poll_path

URI for Ext.Direct events. Default: '/events'.

=item remoting_var

JavaScript variable name used to assign Ext.Direct remoting API object to.
Default: 'Ext.app.REMOTING_API'.

=item polling_var

JavaScript variable name used to assign Ext.Direct polling API object to.
Default: 'Ext.app.POLLING_API'.

=item cookies

Cookies to set when calling server side; can be either HTTP::Cookies object
or a hashref containing key-value pairs. Setting this in constructor will
pass the same cookies to all subsequent client calls.

=item %other

All other arguments are passed to HTTP::Tiny constructor. See L<HTTP::Tiny>
for more detail.

=back

=item get_api

Returns L<RPC::ExtDirect::Client::API> object with Ext.Direct API
declaration published by the server.

=item call(%params)

Calls Ext.Direct remoting method. Arguments are:

=over 8

=item action

Ext.Direct Action (class) name

=item method

Ext.Direct Method name to call

=item arg

Ext.Direct Method arguments; use arrayref for methods that accept ordered
parameters or hashref for named parameters.

=item cookies

Same as with constructor, but sets cookies for this particular call only.

=back

Returns either call Result or Exception.

=item submit

Submits a form request to formHandler method. Arguments should be:

=over 8

=item action

Ext.Direct Action (class) name

=item method

Ext.Direct Method name

=item arg

Method arguments; for formHandlers it should always be a hashref.

=item upload

Arrayref of file names to upload.

=item cookies

Same as with constructor, but sets cookies for this particular call only.

=back

Returns either call Result or Exception.

=item upload

Same as C<submit>.

=item poll

Polls server side for events, returns event data.

=over 8

=item cookies

Same as with constructor, but sets cookies for this particular call only.

=back

=back

=head1 DEPENDENCIES

RPC::ExtDirect::Client depends on the following modules:
L<HTTP::Tiny>, L<JSON>, and L<RPC::ExtDirect::Server> for testing.

=head1 SEE ALSO

For more information on using Ext.Direct with Perl, see L<RPC::ExtDirect>.
L<RPC::ExtDirect::Server> can be used to provide lightweight drop-in for
production environment to run Ext.Direct tests.

=head1 BUGS AND LIMITATIONS

There are no known bugs in this module. Use github tracker to report bugs
(the best way) or just drop me an e-mail. Patches are welcome.

=head1 AUTHOR

Alexander Tokarev E<lt>tokarev@cpan.orgE<gt>

=head1 ACKNOWLEDGEMENTS

I would like to thank IntelliSurvey, Inc for sponsoring my work
on this module.

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2012-2013 Alexander Tokarev.

This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L<perlartistic>.

=cut

