1#
2# Licensed to the Apache Software Foundation (ASF) under one
3# or more contributor license agreements. See the NOTICE file
4# distributed with this work for additional information
5# regarding copyright ownership. The ASF licenses this file
6# to you under the Apache License, Version 2.0 (the
7# "License"); you may not use this file except in compliance
8# with the License. You may obtain a copy of the License at
9#
10#   http://www.apache.org/licenses/LICENSE-2.0
11#
12# Unless required by applicable law or agreed to in writing,
13# software distributed under the License is distributed on an
14# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
15# KIND, either express or implied. See the License for the
16# specific language governing permissions and limitations
17# under the License.
18#
19
20use 5.10.0;
21use strict;
22use warnings;
23
24use HTTP::Request;
25use IO::String;
26use LWP::UserAgent;
27use Thrift;
28use Thrift::Exception;
29use Thrift::Transport;
30
31package Thrift::HttpClient;
32use base('Thrift::Transport');
33use version 0.77; our $VERSION = version->declare("$Thrift::VERSION");
34
35sub new
36{
37    my $classname = shift;
38    my $url       = shift || 'http://localhost:9090';
39
40    my $out = IO::String->new;
41    binmode($out);
42
43    my $self = {
44        url          => $url,
45        out          => $out,
46        timeout      => 100,
47        handle       => undef,
48        headers      => {},
49    };
50
51    return bless($self,$classname);
52}
53
54sub setTimeout
55{
56    my $self    = shift;
57    my $timeout = shift;
58
59    $self->{timeout} = $timeout;
60}
61
62sub setRecvTimeout
63{
64    warn 'setRecvTimeout is deprecated - use setTimeout instead';
65    # note: recvTimeout was never used so we do not need to do anything here
66}
67
68sub setSendTimeout
69{
70    my $self    = shift;
71    my $timeout = shift;
72
73    warn 'setSendTimeout is deprecated - use setTimeout instead';
74
75    $self->setTimeout($timeout);
76}
77
78sub setHeader
79{
80    my $self = shift;
81    my ($name, $value) = @_;
82
83    $self->{headers}->{$name} = $value;
84}
85
86#
87# Tests whether this is open
88#
89# @return bool true if the socket is open
90#
91sub isOpen
92{
93    return 1;
94}
95
96sub open {}
97
98#
99# Cleans up the buffer.
100#
101sub close
102{
103    my $self = shift;
104    if (defined($self->{io})) {
105        close($self->{io});
106        $self->{io} = undef;
107    }
108}
109
110#
111# Guarantees that the full amount of data is read.
112#
113# @return string The data, of exact length
114# @throws TTransportException if cannot read data
115#
116sub readAll
117{
118    my $self = shift;
119    my $len  = shift;
120
121    my $buf = $self->read($len);
122
123    if (!defined($buf)) {
124        die Thrift::TTransportException->new("TSocket: Could not read $len bytes from input buffer",
125                                          Thrift::TTransportException::END_OF_FILE);
126    }
127    return $buf;
128}
129
130#
131# Read and return string
132#
133sub read
134{
135    my $self = shift;
136    my $len  = shift;
137
138    my $buf;
139
140    my $in = $self->{in};
141
142    if (!defined($in)) {
143        die Thrift::TTransportException->new('Response buffer is empty, no request.',
144                                          Thrift::TTransportException::END_OF_FILE);
145    }
146    eval {
147        my $ret = sysread($in, $buf, $len);
148        if (! defined($ret)) {
149            die Thrift::TTransportException->new('No more data available.',
150                                            Thrift::TTransportException::TIMED_OUT);
151        }
152    };
153    if($@){
154        die Thrift::TTransportException->new("$@", Thrift::TTransportException::UNKNOWN);
155    }
156
157    return $buf;
158}
159
160#
161# Write string
162#
163sub write
164{
165    my $self = shift;
166    my $buf  = shift;
167    $self->{out}->print($buf);
168}
169
170#
171# Flush output (do the actual HTTP/HTTPS request)
172#
173sub flush
174{
175    my $self = shift;
176
177    my $ua = LWP::UserAgent->new(
178        'timeout' => ($self->{timeout} / 1000),
179        'agent'   => 'Perl/THttpClient'
180     );
181    $ua->default_header('Accept' => 'application/x-thrift');
182    $ua->default_header('Content-Type' => 'application/x-thrift');
183    $ua->cookie_jar({}); # hash to remember cookies between redirects
184
185    my $out = $self->{out};
186    $out->setpos(0); # rewind
187    my $buf = join('', <$out>);
188
189    my $request = HTTP::Request->new(POST => $self->{url}, undef, $buf);
190    map { $request->header($_ => $self->{headers}->{$_}) } keys %{$self->{headers}};
191    my $response = $ua->request($request);
192    my $content_ref = $response->content_ref;
193
194    my $in = IO::String->new($content_ref);
195    binmode($in);
196    $self->{in} = $in;
197    $in->setpos(0); # rewind
198
199    # reset write buffer
200    $out = IO::String->new;
201    binmode($out);
202    $self->{out} = $out;
203}
204
2051;
206