package JSONRPC::Transport::HTTP;

use strict;
use JSONRPC;
use base qw(JSONRPC);
use vars qw($VERSION);

use HTTP::Request;
use HTTP::Response;

$VERSION = 1.02;

#
#
#


package JSONRPC::Transport::HTTP::Client;

use base qw(JSONRPC::Client);


sub send { require LWP::UserAgent;
    my ($self, $content) = @_;
    my ($url, $proxy_url) = @{$self->{_proxy}};

    my $ua  = LWP::UserAgent->new;

    $ua->proxy(['http','https'], $proxy_url) if($proxy_url);
    $ua->post($url, Content_Type => 'text/plain', Content => $content);
}


#
#
#

package JSONRPC::Transport::HTTP::Server;

use base qw(JSONRPC);

use constant DEFAULT_CHARSET => 'UTF-8';

sub new {
    my $self = shift;
    my %opt  = @_;

    unless (ref $self) {
        my $class = ref($self) || $self;
        $self = $class->SUPER::new(%opt);
    }

    $self->charset( $opt{charset} || DEFAULT_CHARSET );

    return $self;
}


sub handle {
    my $self = shift;
    my $jp   = $self->jsonParser;

    unless(ref $self){ $self = $self->new(@_) }

    my $req;

    if( $req = $self->request ){
        $self->{json_data}
             = eval q| $jp->parse($req->content) |
                or return $self->send_response( $self->invalid_request() );

        if( defined $self->request_id($self->{json_data}->{id}) ){
            my $res = $self->handle_method($req) or return $self->invalid_request();
            return $self->send_response( $self->response($res) );
        }
        else{
            $self->notification();
            $self->send_response( $self->no_response() );
        }
    }
    else{
        $self->send_response( $self->invalid_request() );
    }
}


sub charset {
    $_[0]->{_charset} = $_[1] if(@_ > 1);
    $_[0]->{_charset};
}


sub response {
    my $self    = shift;
    my $res     = shift;
    my $charset = $self->charset;
    my $h    = HTTP::Headers->new;

    $h->header('Content-Type' => "text/plain; charset=$charset");

    HTTP::Response->new(200 => undef, $h, $res);
}


sub invalid_request {
    my $self    = shift;
    my $charset = $self->charset;
    my $h       = HTTP::Headers->new;

    $h->header('Content-Type' => "text/plain; charset=$charset");

    HTTP::Response->new(500 => undef, $h);
}


sub no_response {
    my $self    = shift;
    my $charset = $self->charset;
    my $h       = HTTP::Headers->new;

    $h->header('Content-Type' => "text/plain; charset=$charset");

    HTTP::Response->new(200 => undef, $h);
}


sub send_response { }

#
#
#


package JSONRPC::Transport::HTTP::CGI;

use CGI;
use base qw(JSONRPC::Transport::HTTP::Server);

use constant DEFAULT_CHARSET => 'UTF-8';
use constant MAX_CONTENT_LENGTH => 1024 * 1024 * 5; # 5M


sub new { shift->SUPER::new(@_); }


sub handle {
    my $self = shift->new();
    my %opt  = @_;

    for my $name (qw/charset paramName query/){
        $self->$name( $opt{$name} ) if(exists $opt{$name});
    }

    $self->SUPER::handle();
}


sub request {
    my $self = shift;
    my $q    = $self->query || new CGI;
    my $len  = $ENV{'CONTENT_LENGTH'} || 0;

    if(MAX_CONTENT_LENGTH < $len){ return; }

    my $req = HTTP::Request->new($q->request_method, $q->url);

    return if($req->method ne 'POST');

    if(defined $self->paramName){
        $req->content( $q->param($self->paramName) );
    }
    else{
        my @name = $q->param;
        $req->content(
            ((@name == 1) ? $q->param($name[0]) : $q->param('POSTDATA'))
        );
    }

    return $self->{_request} = $req;
}


sub send_response {
    my ($self, $res) = @_;
    print "Status: " . $res->code . "\015\012" . $res->headers_as_string("\015\012")
           . "\015\012" . $res->content;
}


sub query {
    $_[0]->{_query} = $_[1] if(@_ > 1);
    $_[0]->{_query};
}


sub paramName {
    $_[0]->{_paramName} = $_[1] if(@_ > 1);
    $_[0]->{_paramName};
}

#
#
#

package JSONRPC::Transport::HTTP::Daemon;

use base qw(JSONRPC::Transport::HTTP::Server);

sub new {
    my $self = shift;

    unless (ref $self) {
        my $class = ref($self) || $self;
        $self = $class->SUPER::new(@_);
    }

    my $pkg;
    if(  grep { $_ =~ /^SSL_/ } @_ ){
        $self->{_daemon_pkg} = $pkg = 'HTTP::Daemon::SSL';
    }
    else{
        $self->{_daemon_pkg} = $pkg = 'HTTP::Daemon';
    }
    eval qq| require $pkg; |;
    if($@){ die $@ }

    $self->{_daemon} ||= $pkg->new(@_) or die;

    return $self;
}


sub handle {
    my $self = shift;
    my %opt  = @_;
    my $d    = $self->{_daemon} ||= $self->{_daemon_pkg}->new(@_) or die;

    $self->charset($opt{charset}) if($opt{charset});

    while (my $c = $d->accept) {
        $self->{con} = $c;
        while (my $r = $c->get_request) {
            if ($r->method eq 'POST') {
                $self->request($r);
                $self->SUPER::handle();
            }
            else {
                $self->invalid_request();
            }
            last;
        }
        $c->close;
    }
}



sub request {
    $_[0]->{_request} = $_[1] if(@_ > 1);
    $_[0]->{_request};
}


sub send_response {
    my ($self, $res) = @_;
    $self->{con}->send_response($res);
}


#
#
#

package JSONRPC::Transport::HTTP::Apache;

use base qw(JSONRPC::Transport::HTTP::Server);

use constant MAX_CONTENT_LENGTH => 1024 * 1024 * 5; # 5M

sub new {
    my $self = shift;

    require Apache;
    require Apache::Constants;

    unless (ref $self) {
        my $class = ref($self) || $self;
        $self = $class->SUPER::new(@_);
    }

    return $self;
}


sub request {
    my $self = shift;
    my $r    = shift || Apache->request;
    my $len  = $r->header_in('Content-length');

    $self->{apr} = $r;

    return if($r->method ne 'POST');
    return if(MAX_CONTENT_LENGTH < $len);

    my $req = HTTP::Request->new($r->method, $r->uri);
    my ($buf, $content);

    while( $r->read($buf,$len) ){
        $content .= $buf;
    }

    $req->content($content);

    return $self->{_request} = $req;
}



sub send_response {
    my ($self, $res) = @_;
    my $r = $self->{apr};

    $r->send_http_header("text/plain");
    $r->print($res->content);

    return ($res->code == 200)
            ? &Apache::Constants::OK : &Apache::Constants::SERVER_ERROR;
}


sub configure {
    my $self   = shift;
    my $config = shift->dir_config;
    for my $method (keys %$config) {
        my @values = split(/\s*,\s*/, $config->{$method});
        $self->$method(@values) if($self->can($method));
    }
    $self;
}


1;
__END__

=head1 NAME

JSONRPC::Transport::HTTP

=head1 SYNOPSIS

 #--------------------------
 # In your application class
 package MyApp;

 sub own_method { # called by clients
     my ($server, @params) = @_; # $server is JSONRPC object.
     ...
     # return a scalar value or a hashref or an arryaref.
 }

 #--------------------------
 # In your main cgi script.
 use JSONRPC::Transport::HTTP;
 use MyApp;
 
 # a la XMLRPC::Lite
 JSONRPC::Transport::HTTP::CGI->dispatch_to('MyApp')->handle();


 ##################
 # Daemon version #
 ##################

 use strict;
 use lib qw(. ./lib);
 use JSONRPC::Transport::HTTP;
 
 my $daemon = JSONRPC::Transport::HTTP::Daemon
        ->new(LocalPort => 8080)
        ->dispatch_to('MyApp/Test', 'MyApp/Test2');
 
 $daemon->handle();

 ##################
 # Apache version #
 ##################

 http.conf or .htaccess

   SetHandler  perl-script
   PerlHandler Apache::JSONRPC
   PerlModule  MyApp::Test
   PerlSetVar  dispatch_to "MyApp::Test, MyApp/Test2/"


 #--------------------------
 # Client
 #--------------------------

 use JSONRPC::Transport::HTTP;
 my $uri = 'http://www.example.com/MyApp/Test/';

 my $res = JSONRPC::Transport::HTTP
            ->proxy($uri)
            ->call('echo',['This is test.'])
            ->result;

 if($res->error){
   print $res->error,"\n";
 }
 else{
   print $res->result,"\n";
 }

 # or

 my $client = JSONRPC::Transport::HTTP->proxy($uri);
 
 print $client->echo('This is test.'); # the alias, _echo is same.


=head1 TRANSITION PLAN

In the next large update version, JSON and JSONRPC modules are split.

  JSONRPC* and Apache::JSONRPC are deleted from JSON dist.
  JSONRPC::Client, JSONRPC::Server and JSONRPC::Procedure in JSON::RPC dist.

  Modules in JSON::RPC dist supports JSONRPC protocol v1.1 and 1.0.


=head1 DESCRIPTION

This module is L<JSONRPC> subclass.
Most ideas were borrowed from L<XMLRPC::Lite>.
Currently C<JSONRPC> provides only CGI server function.


=head1 CHARSET

When the module returns response, its charset is UTF-8 by default.
You can change it via passing a key/value pair into handle().

 my %charset = (charset => 'EUC-JP');
 JSONRPC::Transport::HTTP::CGI->dispatch_to('MyApp')->handle(%charset);

=head1 QUERY OBJECT

If you want to use any other query object instead of C<CGI>
for JSONRPC::Transport::HTTP::CGI, you can pass C<query> option and
C<paramName>.

 my %opt = (
   query     => $session, # CGI::Session object
   paramName => 'json',
 );

 JSONRPC::Transport::HTTP::CGI->dispatch_to('MyApp')->handle(%opt);


=head1 CAUTION

JSONRPC::Transport::HTTP::CGI requires CGI.pm which version is more than 2.9.2.
(the core module in Perl 5.8.1.)


Since verion 1.0, JSONRPC::Transport::HTTP requires L<HTTP::Request>
and L<HTTP::Response>. For using JSONRPC::Transport::HTTP::Client,
you need L<LWP::UserAgent>.

=head1 SEE ALSO

L<JSONRPC>
L<JSON>
L<XMLRPC::Lite>
L<http://json-rpc.org/>


=head1 AUTHOR

Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2005 by Makamaka Hannyaharamitu

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut