記念こぺ

package AnyEvent::ReverseHTTP;

use strict;
use 5.008_001;
our $VERSION = '0.01';

use Carp;
use AnyEvent::Util;
use AnyEvent::HTTP;
use HTTP::Request;
use HTTP::Response;
use URI::Escape;
use Scalar::Util;

use base qw(Exporter);
our @EXPORT = qw(reverse_http);

use Any::Moose;

has endpoint => (
    is => 'rw', isa => 'Str',
    required => 1, default => "http://www.reversehttp.net/reversehttp",
);

has label => (
    is => 'rw', isa => 'Str',
    required => 1,
    lazy => 1, default => sub { "anyevent" . int rand 100000 },
);

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

has on_register => (
    is => 'rw', isa => 'CodeRef',
    default => sub { sub { warn "Public Application URL: $_[0]\n" } },
);

has on_error => (
    is => 'rw', isa => 'CodeRef',
    default => sub { sub { Carp::croak(@_) } },
);

has on_request => (
    is => 'rw', isa => 'CodeRef',
    default => sub { sub { Carp::croak("on_request handler is not defined!") } },
);

sub reverse_http {
    my $cb = pop;

    my @args =
        @_ == 1 ? qw(label) :
        @_ == 2 ? qw(label token) :
        @_ >= 3 ? qw(endpoint label token) : ();

    my %args; @args{@args} = @_;
    return __PACKAGE__->new(%args, on_request => $cb)->connect;
}

sub connect {
    my $self = shift;

    my %query = (name => $self->label);
    $query{token} = $self->token if $self->token;

    my $body = join "&", map "$_=" . URI::Escape::uri_escape($query{$_}), keys %query;

    my $guard = http_post $self->endpoint, $body, sub {
        my($body, $hdr) = @_;

        if ($hdr->{Status} eq '201' || $hdr->{Status} eq '204') {
            my $app_url = _extract_link($hdr, 'related');
            $self->on_register->($app_url);
        } else {
            return $self->on_error->("$hdr->{Status}: $hdr->{Reason}");
        }

        my $poller; $poller = sub {
            my($body, $hdr) = @_;

            if ($hdr->{Status} eq '200') {
                my $req  = HTTP::Request->parse($body);
                my $res  = $self->on_request->($req);

                my $send_response = sub {
                    my $res = shift;

                    # Duck typing for as_string, but accepts plaintext too for 200
                    unless (Scalar::Util::blessed($res) && $res->can('as_string')) {
                        my $content = $res;
                        $res = HTTP::Response->new(200);
                        $res->content_type('text/plain');
                        $res->content($content);
                    }

                    $res->protocol("HTTP/1.1"); # Upgrade since reversehttp.net requires so

                    # HTTP::Response->as_string by default adds a new line which could be harmful
                    my $res_body = $res->as_string;
                    chomp $res_body if $res->content_type eq 'text/plain';

                    http_post $hdr->{URL}, $res_body,
                        headers => { 'content-type' => 'message/http' },
                            sub {
                                my($body, $hdr) = @_;
                                if ($hdr->{Status} ne '202') {
                                    $self->on_error->("$hdr->{Status}: $hdr->{Reason}");
                                }
                            };
                };

                if ((Scalar::Util::blessed($res) || '') eq 'AnyEvent::CondVar') {
                    $res->cb(sub {
                        my $response = $res->recv;
                        undef $res;
                        $send_response->($response);
                    });
                }
                else {
                    $send_response->($res);
                }
            }

            my $next = _extract_link($hdr, 'next');
            http_get $next, $poller;
        };

        my $url = _extract_link($hdr, 'first');
        http_get $url, $poller;
    };

    return AnyEvent::Util::guard { undef $guard; undef $self };
}

sub _extract_link {
    my($hdr, $rel) = @_;
    my @links = $hdr->{link} =~ /<([^>]*)>;\s*rel="\Q$rel\E"/g;
    return $links[0];
}

no Any::Moose;
__PACKAGE__->meta->make_immutable;

1;
__END__

=encoding utf-8

=for stopwords

=head1 NAME

AnyEvent::ReverseHTTP - reversehttp for AnyEvent

=head1 SYNOPSIS

  use AnyEvent::ReverseHTTP;

  # simple Hello World server
  my $guard = reverse_http "myserver123", sub {
      my $req = shift;
      return "Hello World"; # You can return HTTP::Response object for more control
  };

  # more controls over options and callbacks
  my $server = AnyEvent::ReverseHTTP->new(
      endpoint => "http://www.reversehttp.net/reversehttp",
      label    => "aedemo1234",
      token    => "-", # optional
  );

  $server->on_register(sub {
      my $pub_url = shift;
  });

  $server->on_request(sub {
      my $req = shift;
      # $req is HTTP::Request, return HTTP::Response
  });

  my $guard = $server->connect;

  AnyEvent->condvar->recv;

=head1 DESCRIPTION

AnyEvent::ReverseHTTP is an AnyEvent module that acts as a Reverse
HTTP server (which is actually a polling client for Reverse HTTP
gateway).

This module implements simple Reverse HTTP client that's tested
against I<reversehttp.net> demo server. More complicated specification
like relaying or pipelining is not (yet) implemented.

=head1 AUTHOR

Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>

=head1 LICENSE

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

=head1 SEE ALSO

L<http://www.reversehttp.net/reverse-http-spec.html>

=cut