blob: 91c7f46e7958da0d05092bb3d363c96d9f139038 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
package Plack::Client;
use strict;
use warnings;
use HTTP::Message::PSGI;
use HTTP::Request;
use LWP::UserAgent;
use Plack::Response;
use Scalar::Util qw(blessed);
sub new {
my $class = shift;
my %params = @_;
die 'XXX' if exists($params{apps}) && ref($params{apps}) ne 'HASH';
bless {
apps => $params{apps},
ua => exists $params{ua} ? $params{ua} : LWP::UserAgent->new,
}, $class;
}
sub apps { shift->{apps} }
sub ua { shift->{ua} }
sub app_for {
my $self = shift;
my ($for) = @_;
return $self->apps->{$for};
}
sub request {
my $self = shift;
my $req = blessed($_[0]) && ($_[0]->isa('HTTP::Request')
|| $_[0]->isa('Plack::Request'))
? $_[0]
: ref($_[0]) eq 'HASH'
? Plack::Request->new(@_)
: HTTP::Request->new(@_);
# both Plack::Request and HTTP::Request have a ->uri method
my $scheme = $req->uri->scheme;
my $res;
if ($scheme eq 'psgi') {
my ($app_key, $path) = $self->_parse_request($req->uri->opaque);
# to_psgi doesn't like non-http uris
$req->uri($path);
my $env = $req->isa('HTTP::Request') ? $req->to_psgi : $req->env;
my $app = $self->app_for($app_key);
die 'XXX' unless $app;
my $psgi_res = $app->($env);
die 'XXX' unless ref($psgi_res) eq 'ARRAY';
$res = Plack::Response->new(@$psgi_res);
}
elsif ($scheme eq 'http' || $scheme eq 'https') {
$req = $self->_req_from_psgi($req)
if $req->isa('Plack::Request');
my $http_res = $self->ua->simple_request($req); # or just ->request?
$res = Plack::Response->new(
map { $http_res->$_ } qw(code headers content)
);
}
else {
die 'XXX';
}
return $res;
}
sub _req_from_psgi {
my $self = shift;
my ($req) = @_;
return HTTP::Request->new(
map { $req->$_ } qw(method uri headers raw_body)
);
}
sub _parse_request {
my $self = shift;
my ($req) = @_;
my ($app, $path) = $req =~ m+^//(.*?)(/.*)$+;
return ($app, $path);
}
sub get { shift->request('GET', @_) }
sub head { shift->request('HEAD', @_) }
sub post { shift->request('POST', @_) }
sub put { shift->request('PUT', @_) }
sub delete { shift->request('DELETE', @_) }
1;
|
