File Coverage

blib/lib/AMF/Connection.pm
Criterion Covered Total %
statement 24 144 16.6
branch 0 44 0.0
condition 0 30 0.0
subroutine 8 32 25.0
pod 20 20 100.0
total 52 270 19.2


line stmt bran cond sub pod time code
1             package AMF::Connection;
2              
3 1     1   28789 use AMF::Connection::Message;
  1         4  
  1         31  
4 1     1   7 use AMF::Connection::MessageBody;
  1         2  
  1         21  
5 1     1   6 use AMF::Connection::OutputStream;
  1         2  
  1         19  
6 1     1   5 use AMF::Connection::InputStream;
  1         1  
  1         26  
7              
8 1     1   1478 use LWP::UserAgent;
  1         79011  
  1         36  
9 1     1   7380 use HTTP::Cookies;
  1         12365  
  1         38  
10              
11             #use Data::Dumper; #for debug
12              
13 1     1   10 use Carp;
  1         3  
  1         90  
14 1     1   7 use strict;
  1         2  
  1         2465  
15              
16             our $VERSION = '0.32';
17              
18             our $HASMD5 = 0;
19             {
20             local $@;
21             eval { require Digest::MD5; };
22             $HASMD5 = ($@) ? 0 : 1 ;
23             };
24              
25             our $HASUUID;
26             {
27             local $@;
28             eval { require Data::UUID; };
29             $HASUUID = ($@) ? 0 : 1 ;
30             }
31              
32             our $HAS_LWP_PROTOCOL_SOCKS;
33             {
34             local $@;
35             eval { require LWP::Protocol::socks };
36             $HAS_LWP_PROTOCOL_SOCKS = ($@) ? 0 : 1 ;
37             }
38              
39             sub new {
40 0     0 1   my ($proto, $endpoint) = @_;
41 0   0       my $class = ref($proto) || $proto;
42              
43 0           my $self = {
44             'endpoint' => $endpoint,
45             'headers' => [],
46             'http_headers' => {},
47             'http_cookie_jar' => new HTTP::Cookies(),
48             'response_counter' => 0,
49             'encoding' => 0, # default is AMF0 encoding
50             'ua' => new LWP::UserAgent(),
51             'append_to_endpoint' => ''
52             };
53              
54 0           $self->{'ua'}->cookie_jar( $self->{'http_cookie_jar'} );
55              
56 0           return bless($self, $class);
57             };
58              
59             # plus add paramters, referer, user agent, authentication/credentials ( see also SecureAMFChannel stuff ),
60             # plus timezone on retunred dates to pass to de-serializer - see AMF3 spec saying "it is suggested that time zone be queried independnetly as needed" - unelss local DateTime default to right locale!
61              
62             # we pass the string, and let Storable::AMF to parse the options into a scalar - see Input/OutputStream and Storable::AMF0 documentation
63              
64             sub setInputAMFOptions {
65 0     0 1   my ($class, $options) = @_;
66              
67 0           $class->{'input_amf_options'} = $options;
68             };
69              
70             sub setOutputAMFOptions {
71 0     0 1   my ($class, $options) = @_;
72              
73 0           $class->{'output_amf_options'} = $options;
74             };
75              
76             # useful when input and output options are the same
77             sub setAMFOptions {
78 0     0 1   my ($class, $options) = @_;
79              
80 0           $class->setInputAMFOptions ($options);
81 0           $class->setOutputAMFOptions ($options);
82             };
83              
84             sub getInputAMFOptions {
85 0     0 1   my ($class) = @_;
86              
87 0           return $class->{'input_amf_options'};
88             };
89              
90             sub getOutputAMFOptions {
91 0     0 1   my ($class) = @_;
92              
93 0           return $class->{'output_amf_options'};
94             };
95              
96             sub setEndpoint {
97 0     0 1   my ($class, $endpoint) = @_;
98              
99 0           $class->{'endpoint'} = $endpoint;
100             };
101              
102             sub getEndpoint {
103 0     0 1   my ($class) = @_;
104              
105 0           return $class->{'endpoint'};
106             };
107              
108             sub setHTTPProxy {
109 0     0 1   my ($class, $proxy) = @_;
110              
111 0 0 0       if( ($proxy =~ m!^socks://(.*?):(\d+)!) &&
112             (!$HAS_LWP_PROTOCOL_SOCKS) ) {
113 0           croak "LWP::Protocol::socks is required for SOCKS support";
114             };
115              
116 0           $class->{'http_proxy'} = $proxy;
117              
118 0           $class->{'ua'}->proxy( [qw(http https)] => $class->{'http_proxy'} );
119             };
120              
121             sub getHTTPProxy {
122 0     0 1   my ($class) = @_;
123              
124 0           return $class->{'http_proxy'};
125             };
126              
127             sub setEncoding {
128 0     0 1   my ($class, $encoding) = @_;
129              
130 0 0 0       croak "Unsupported AMF encoding $encoding"
131             unless( $encoding==0 or $encoding==3 );
132              
133 0           $class->{'encoding'} = $encoding;
134             };
135              
136             sub getEncoding {
137 0     0 1   my ($class) = @_;
138              
139 0           return $class->{'encoding'};
140             };
141              
142             sub addHeader {
143 0     0 1   my ($class, $header, $value, $required) = @_;
144              
145 0 0         if( ref($header) ) {
146 0 0         croak "Not a valid header $header"
147             unless( $header->isa("AMF::Connection::MessageHeader") );
148             } else {
149 0 0         $header = new AMF::Connection::MessageHeader( $header, $value, ($required==1) ? 1 : 0 );
150             };
151              
152 0           push @{ $class->{'headers'} }, $header;
  0            
153             };
154              
155             sub addHTTPHeader {
156 0     0 1   my ($class, $name, $value) = @_;
157              
158 0           $class->{'http_headers'}->{ $name } = $value ;
159             };
160              
161             sub setUserAgent {
162 0     0 1   my ($class, $ua) = @_;
163              
164 0 0 0       croak "Not a valid User-Agent $ua"
      0        
165             unless( ref($ua) and $ua->isa("LWP::UserAgent") and $ua->can("post") );
166              
167             # the passed UA might have a different agent and cookie jar settings
168 0           $class->{'ua'} = $ua;
169              
170             # make sure we set the proxy if was already set
171             # NOTE - we do not re-check SOCKS support due we assume the setHTTPProxy() was called earlier
172 0 0 0       $class->{'ua'}->proxy( [qw(http https)] => $class->{'http_proxy'} )
173             if( exists $class->{'http_proxy'} and defined $class->{'http_proxy'} );
174              
175             # copy/pass over cookies too
176 0           $class->{'ua'}->cookie_jar( $class->{'http_cookie_jar'} );
177             };
178              
179             sub setHTTPCookieJar {
180 0     0 1   my ($class, $cookie_jar) = @_;
181              
182 0 0 0       croak "Not a valid cookies jar $cookie_jar"
183             unless( ref($cookie_jar) and $cookie_jar->isa("HTTP::Cookies") );
184              
185             # TODO - copy/pass over the current cookies (in-memory by default) if any set
186 0     0     $class->{'http_cookie_jar'}->scan( sub { $cookie_jar->set_cookie( @_ ); } );
  0            
187              
188 0           $class->{'http_cookie_jar'} = $cookie_jar;
189              
190             # tell user agent to use new cookie jar
191 0           $class->{'ua'}->cookie_jar( $class->{'http_cookie_jar'} );
192             };
193              
194             sub getHTTPCookieJar {
195 0     0 1   my ($class) = @_;
196            
197 0           return $class->{'http_cookie_jar'};
198             };
199              
200             # send "flex.messaging.messages.RemotingMessage"
201              
202             sub call {
203 0     0 1   my ($class, $operation, $arguments, $destination) = @_;
204              
205 0           my @call = $class->callBatch ({ "operation" => $operation,
206             "arguments" => $arguments,
207             "destination" => $destination });
208              
209 0 0         return (wantarray) ? @call : $call[0];
210             };
211              
212             sub callBatch {
213 0     0 1   my ($class, @batch) = @_;
214              
215 0           my $request = new AMF::Connection::Message;
216 0           $request->setEncoding( $class->{'encoding'} );
217              
218             # add AMF any request headers
219 0           map { $request->addHeader( $_ ); } @{ $class->{'headers'} };
  0            
  0            
220              
221             # TODO - prepare HTTP/S request headers based on AMF headers received/set if any - and credentials
222              
223 0           foreach my $call (@batch)
224             {
225             next
226 0 0 0       unless (defined $call && ref ($call) =~ m/HASH/
      0        
      0        
227             && defined $call->{'operation'} && defined $call->{'arguments'});
228              
229 0           my $operation = $call->{'operation'};
230 0           my $arguments = $call->{'arguments'};
231              
232 0           my $body = new AMF::Connection::MessageBody;
233 0           $class->{'response_counter'}++;
234 0           $body->setResponse( "/".$class->{'response_counter'} );
235              
236 0 0         if( $class->{'encoding'} == 3 ) { # AMF3
237 0           $body->setTarget( 'null' );
238              
239 0           my (@operation) = split('\.',$operation);
240 0           my $method = pop @operation;
241 0           my $service = join('.',@operation);
242 0 0         my $destination = (defined $call->{'destination'}) ? $call->{'destination'} : $service;
243              
244 0           my $remoting_message = $class->_brew_flex_remoting_message( $service, $method, {}, $arguments, $destination);
245              
246 0           $body->setData( [ $remoting_message ] ); # it seems we need array ref here - to be checked
247             } else {
248 0           $body->setTarget( $operation );
249 0           $body->setData( $arguments );
250             };
251              
252 0           $request->addBody( $body );
253             }
254              
255 0           my $request_stream = new AMF::Connection::OutputStream($class->{'output_amf_options'});
256              
257             # serialize request
258 0           $request->serialize($request_stream);
259              
260             #use Data::Dumper;
261             #print STDERR Dumper( $request );
262              
263             # set any extra HTTP header
264 0           map { $class->{'ua'}->default_header( $_ => $class->{'http_headers'}->{$_} ); } keys %{ $class->{'http_headers'} };
  0            
  0            
265              
266 0           my $http_response = $class->{'ua'}->post(
267             $class->{'endpoint'}.$class->{'append_to_endpoint'}, # TODO - check if append to URL this really work for HTTP POST
268             Content_Type => "application/x-amf",
269             Content => $request_stream->getStreamData()
270             );
271              
272 0 0         croak "HTTP POST error: ".$http_response->status_line."\n"
273             unless($http_response->is_success);
274              
275 0           my $response_stream = new AMF::Connection::InputStream( $http_response->decoded_content, $class->{'input_amf_options'});
276 0           my $response = new AMF::Connection::Message;
277 0           $response->deserialize( $response_stream );
278              
279             #print STDERR Dumper( $response )."\n";
280              
281             # process AMF response headers
282 0           $class->_process_response_headers( $response );
283              
284 0           my @all = @{ $response->getBodies() };
  0            
285              
286             # we make sure the main response is always returned first
287 0 0         return (wantarray) ? @all : $all[0];
288             };
289              
290             # TODO
291             #
292             # sub command { } - to send "flex.messaging.messages.CommandMessage" instead
293             #
294              
295             sub setCredentials {
296 0     0 1   my ($class, $username, $password) = @_;
297              
298 0           $class->addHeader( 'Credentials', { 'userid' => $username,'password' => $password }, 0 );
299             };
300              
301              
302             sub _process_response_headers {
303 0     0     my ($class,$message) = @_;
304              
305 0           foreach my $header (@{ $message->getHeaders()}) {
  0            
306 0 0         if($header->getName eq 'ReplaceGatewayUrl') { # another way used by server to keep cookies-less sessions
    0          
307 0 0         $class->setEndpoint( $header->getValue )
308             unless( ref($header->getValue) );
309             } elsif($header->getName eq 'AppendToGatewayUrl') { # generally used for cokies-less sessions E.g. ';jsessionid=99226346ED3FF5296D08146B02ECCA28'
310 0 0         $class->{'append_to_endpoint'} = $header->getValue
311             unless( ref($header->getValue) );
312             };
313             };
314             };
315              
316             # just an hack to avoid rewrite class mapping local-to-remote and viceversa and make Storable::AMF happy
317             sub _brew_flex_remoting_message {
318 0     0     my ($class,$source,$operation,$headers,$body,$destination) = @_;
319              
320 0 0         return bless( {
321             'clientId' => _generateID(),
322             'destination' => $destination,
323             'messageId' => _generateID(),
324             'timestamp' => time() . '00',
325             'timeToLive' => 0,
326             'headers' => ($headers) ? $headers : {},
327             'body' => $body,
328             'correlationId' => undef,
329             'operation' => $operation,
330             'source' => $source # for backwards compatibility - google for it!
331             }, 'flex.messaging.messages.RemotingMessage' );
332             };
333              
334             sub _generateID {
335 0     0     my $uniqueid;
336              
337 0 0         if($HASUUID) {
    0          
338 0           eval {
339 0           my $ug = new Data::UUID;
340 0           $uniqueid = $ug->to_string( $ug->create() );
341             };
342             } elsif ($HASMD5) {
343 0           eval {
344 0           $uniqueid = substr(Digest::MD5::md5_hex(Digest::MD5::md5_hex(time(). {}. rand(). $$)), 0, 32);
345             };
346             } else {
347 0           $uniqueid ="";
348 0           my $length=16;
349              
350 0           my $j;
351 0           for(my $i=0 ; $i< $length ;) {
352 0           $j = chr(int(rand(127)));
353              
354 0 0         if($j =~ /[a-zA-Z0-9]/) {
355 0           $uniqueid .=$j;
356 0           $i++;
357             };
358             };
359             };
360              
361 0           return $uniqueid;
362             };
363              
364             1;
365             __END__