File Coverage

blib/lib/AnyEvent/HTTPD/ExtDirect.pm
Criterion Covered Total %
statement 170 187 90.9
branch 32 46 69.5
condition 10 26 38.4
subroutine 28 30 93.3
pod 3 6 50.0
total 243 295 82.3


line stmt bran cond sub pod time code
1             package AnyEvent::HTTPD::ExtDirect;
2              
3 4     4   611038 use parent 'AnyEvent::HTTPD';
  4         8  
  4         23  
4              
5 4     4   106863 use common::sense;
  4         12  
  4         26  
6              
7 4     4   149 use Carp;
  4         13  
  4         211  
8 4     4   2050 use IO::File;
  4         6229  
  4         453  
9 4     4   2633 use File::Temp;
  4         28248  
  4         456  
10 4     4   25 use File::Basename;
  4         6  
  4         265  
11              
12 4     4   20 use AnyEvent::HTTPD::Request;
  4         5  
  4         77  
13              
14 4     4   18 use RPC::ExtDirect::Util::Accessor;
  4         5  
  4         105  
15 4     4   16 use RPC::ExtDirect::Config;
  4         6  
  4         74  
16 4     4   45 use RPC::ExtDirect::API;
  4         6  
  4         34  
17 4     4   83 use RPC::ExtDirect;
  4         5  
  4         25  
18              
19             #
20             # This module is not compatible with RPC::ExtDirect < 3.0
21             #
22              
23             croak __PACKAGE__." requires RPC::ExtDirect 3.0+"
24             if $RPC::ExtDirect::VERSION lt '3.0';
25              
26             ### PACKAGE GLOBAL VARIABLE ###
27             #
28             # Version of the module
29             #
30              
31             our $VERSION = '3.02';
32              
33             ### PUBLIC CLASS METHOD (CONSTRUCTOR) ###
34             #
35             # Instantiate a new AnyEvent::HTTPD::ExtDirect object
36             #
37              
38             sub new {
39 20     20 1 102400 my $class = shift;
40            
41 20 50 33     179 my %arg = @_ == 1 && 'HASH' eq ref $_[0] ? %{ $_[0] }
  0         0  
42             : @_
43             ;
44            
45 20   33     197 my $api = delete $arg{api} || RPC::ExtDirect->get_api();
46 20   33     175 my $config = delete $arg{config} || $api->config;
47            
48 20         167 $config->add_accessors(
49             overwrite => 1,
50             complex => [{
51             accessor => 'router_class_anyevent',
52             fallback => 'router_class',
53             }, {
54             accessor => 'eventprovider_class_anyevent',
55             fallback => 'eventprovider_class',
56             }],
57             );
58            
59 20         9122 for my $var ( qw/ router_class eventprovider_class / ) {
60 40         80 my $method = "${var}_anyevent";
61            
62 40 50       171 $config->$method( delete $arg{$var} ) if exists $arg{$var};
63             }
64            
65             # AnyEvent::HTTPD wants only IP addresses
66 20 50       116 $arg{host} = '127.0.0.1' if $arg{host} =~ /localhost/io;
67              
68 20         136 my $self = $class->SUPER::new(%arg);
69            
70 20         8401 $self->config($config);
71 20         528 $self->api($api);
72              
73 20         159 return $self;
74             }
75              
76             ### PUBLIC INSTANCE METHOD ###
77             #
78             # Run the server
79             #
80              
81             sub run {
82 0     0 1 0 my ($self) = @_;
83            
84 0         0 my $config = $self->config;
85              
86 0         0 $self->set_callbacks(
87             api_path => $config->api_path,
88             router_path => $config->router_path,
89             poll_path => $config->poll_path,
90             );
91              
92 0         0 $self->SUPER::run();
93             }
94              
95             ### PUBLIC INSTANCE METHOD ###
96             #
97             # Handle Ext.Direct API calls
98             #
99              
100             sub handle_api {
101 3     3 0 186647 my ($self, $req) = @_;
102              
103             # Get the API JavaScript chunk
104 3         6 my $js = eval {
105 3         82 $self->api->get_remoting_api( config => $self->config )
106             };
107              
108             # If JS API call failed, return error
109 3 50       8476 return $self->_error_response if $@;
110              
111             # Content length should be in octets
112 4     4   3518 my $content_length = do { use bytes; my $len = length $js };
  4         31  
  4         15  
  3         6  
  3         7  
113              
114 3         23 $req->respond([
115             200,
116             'OK',
117             {
118             'Content-Type' => 'application/javascript',
119             'Content-Length' => $content_length,
120             },
121             $js
122             ]);
123              
124 3         1537 $self->stop_request;
125             }
126              
127             ### PUBLIC INSTANCE METHOD ###
128             #
129             # Handle Ext.Direct method requests
130             #
131              
132             sub handle_router {
133 12     12 0 982045 my ($self, $req) = @_;
134            
135 12 50       53 if ( $req->method ne 'POST' ) {
136 0         0 $req->respond( $self->_error_response );
137 0         0 $self->stop_request;
138            
139 0         0 return;
140             }
141            
142 12         475 my $config = $self->config;
143 12         335 my $api = $self->api;
144              
145             # Naked AnyEvent::HTTPD::Request object doesn't provide several
146             # utility methods we'll need down below, and we will need it as
147             # an environment object, too
148 12         121 my $env = bless $req, __PACKAGE__.'::Env';
149              
150             # We're trying to distinguish between a raw POST and a form call
151 12         42 my $router_input = $self->_extract_post_data($env);
152              
153             # If the extraction fails, undef is returned by the method above
154 12 50       42 if ( !defined $router_input ) {
155 0         0 $req->respond( $self->_error_response );
156 0         0 $self->stop_request;
157              
158 0         0 return;
159             }
160            
161 12         350 my $router_class = $config->router_class_anyevent;
162            
163 12         1384 eval "require $router_class";
164            
165 12         2211 my $router = $router_class->new(
166             config => $config,
167             api => $api,
168             );
169              
170             # No need for eval here, Router won't throw exceptions
171 12         185 my $result = $router->route($router_input, $env);
172              
173             # Router result is Plack-compatible arrayref; there's not much
174             # difference in what AnyEvent::HTTPD expects so we just convert it
175             # in place
176 12         112 $req->respond([
177             200,
178             'OK',
179 12         24726 +{ @{ $result->[1] } },
180             $result->[2]->[0],
181             ]);
182            
183 12         6171 $self->stop_request;
184             }
185              
186             ### PUBLIC INSTANCE METHOD ###
187             #
188             # Polls Event handlers for events, returning serialized stream
189             #
190              
191             sub handle_events {
192 5     5 0 396153 my ($self, $req) = @_;
193            
194             # Only GET and POST methods are supported for polling
195 5         27 my $method = $req->method;
196            
197 5 50 33     55 if ( $method ne 'GET' && $method ne 'POST' ) {
198 0         0 $req->respond( $self->_error_response );
199 0         0 $self->stop_request;
200            
201 0         0 return;
202             }
203            
204 5         249 my $config = $self->config;
205 5         168 my $api = $self->api;
206            
207 5         52 my $env = bless $req, __PACKAGE__.'::Env';
208            
209 5         123 my $provider_class = $config->eventprovider_class_anyevent;
210            
211 5         750 eval "require $provider_class";
212            
213 5         1747 my $provider = $provider_class->new(
214             config => $config,
215             api => $api,
216             );
217            
218             # Polling for Events is safe from exceptions
219 5         86 my $http_body = $provider->poll($env);
220            
221             my $content_length
222 4     4   1631 = do { no warnings 'void'; use bytes; length $http_body };
  4     4   5  
  4         149  
  4         18  
  4         4  
  4         14  
  5         15782  
  5         14  
223            
224 5         48 $req->respond([
225             200,
226             'OK',
227             {
228             'Content-Type' => 'application/json; charset=utf-8',
229             'Content-Length' => $content_length,
230             },
231             $http_body,
232             ]);
233            
234 5         2550 $self->stop_request;
235             }
236              
237             ### PUBLIC INSTANCE METHOD ###
238             #
239             # Register the callbacks for Ext.Direct handlers.
240             # This effectively "primes" the server but does not make it
241             # enter a blocking wait.
242             #
243              
244             sub set_callbacks {
245 20     20 1 1426 my ($self, %arg) = @_;
246              
247 20         436 my $config = $self->config;
248            
249 20   33     148 my $api_path = $arg{api_path} || $config->api_path;
250 20   33     63 my $router_path = $arg{router_path} || $config->router_path;
251 20   33     64 my $poll_path = $arg{poll_path} || $config->poll_path;
252            
253 20         195 $self->reg_cb(
254             $api_path => $self->can('handle_api'),
255             $router_path => $self->can('handle_router'),
256             $poll_path => $self->can('handle_events'),
257             );
258             }
259              
260             ### PUBLIC INSTANCE METHODS ###
261             #
262             # Read-write accessors.
263             #
264              
265             RPC::ExtDirect::Util::Accessor::mk_accessors(
266             simple => [qw/ api config /],
267             );
268              
269             ############## PRIVATE METHODS BELOW ##############
270              
271             ### PRIVATE INSTANCE METHOD ###
272             #
273             # Deals with intricacies of POST-fu and returns something suitable to
274             # feed to Router (string or hashref, really). Or undef if something
275             # goes too wrong to recover.
276             #
277             # This code was mostly copied from the Plack gateway and adapted
278             # for AnyEvent::HTTPD.
279             #
280              
281             sub _extract_post_data {
282 12     12   28 my ($self, $req) = @_;
283              
284             # The smartest way to tell if a form was submitted that *I* know of
285             # is to look for 'extAction' and 'extMethod' keywords in form params.
286 12   66     43 my $is_form = $req->param('extAction') && $req->param('extMethod');
287              
288             # If form is not involved, it's easy: just return raw POST (or undef)
289 12 100       36 if ( !$is_form ) {
290 9         45 my $postdata = $req->content;
291 9 50       59 return $postdata ne '' ? $postdata
292             : undef
293             ;
294             };
295              
296             # If any files are attached, extUpload field will be set to 'true'
297 3         8 my $has_uploads = $req->param('extUpload') eq 'true';
298              
299             # Outgoing hash
300 3         4 my %keyword;
301              
302             # Pluck all parameters from the Request object
303 3         21 for my $param ( $req->params ) {
304 27         54 my @values = $req->param($param);
305 27 100       77 $keyword{ $param } = @values == 0 ? undef
    50          
306             : @values == 1 ? $values[0]
307             : [ @values ]
308             ;
309             };
310              
311             # Find all file uploads
312 3 100       11 for ( $has_uploads ? ($has_uploads) : () ) {
313             # The list of fields that contain file uploads
314 2         7 my @upload_fields = $req->upload_fields;
315            
316 2 50       7 last unless @upload_fields;
317            
318 2         3 my @uploaded_files;
319            
320 2         4 for my $field_name ( @upload_fields ) {
321 2         7 my $uploads = $req->raw_param($field_name);
322              
323             # We need files as a formatted list
324 2         3 my @field_uploads = map { $self->_format_upload($_) } @$uploads;
  4         11  
325 2         4 push @uploaded_files, @field_uploads;
326              
327             # Now remove the field that contained files
328 2         8 delete @keyword{ $field_name };
329             }
330              
331 2 50       14 $keyword{ '_uploads' } = \@uploaded_files if @uploaded_files;
332             };
333              
334             # Remove extType because it's meaningless later on
335 3         7 delete $keyword{ extType };
336              
337             # Fix TID so that it comes as number (JavaScript is picky)
338 3 50       13 $keyword{ extTID } += 0 if exists $keyword{ extTID };
339              
340 3         7 return \%keyword;
341             }
342              
343             ### PRIVATE INSTANCE METHOD ###
344             #
345             # Take the file content and metadata and format it in a way
346             # that RPC::ExtDirect handlers expect
347             #
348              
349             sub _format_upload {
350 4     4   4 my ($self, $upload) = @_;
351            
352 4     4   1928 my $content_length = do { use bytes; length $upload->[0] };
  4         6  
  4         12  
  4         4  
  4         8  
353            
354 4         17 my ($fh, $fname) = File::Temp::tempfile;
355            
356 4         1275 binmode $fh;
357 4         212 syswrite $fh, $upload->[0], $content_length;
358            
359 4         16 sysseek $fh, 0, 0;
360            
361             # We don't need the file content anymore, so try to release
362             # the memory it takes
363 4         10 $upload->[0] = undef;
364            
365 4         6 my $filename = $upload->[2];
366 4         173 my $basename = File::Basename::basename($filename);
367 4         9 my $type = $upload->[1];
368 4         34 my $handle = IO::File->new_from_fd($fh->fileno, '<');
369              
370             return {
371 4         287 filename => $filename,
372             basename => $basename,
373             type => $type,
374             size => $content_length,
375             path => $fname,
376             handle => $handle,
377             };
378             }
379              
380             ### PRIVATE INSTANCE METHOD ###
381             #
382             # Return an error response formatted to AnyEvent::HTTPD likes
383             #
384              
385             sub _error_response {
386 0     0   0 [ 500, 'Internal Server Error', { 'Content-Type' => 'text/html' }, '' ]
387             }
388              
389             package
390             AnyEvent::HTTPD::ExtDirect::Env;
391              
392 4     4   687 use parent 'AnyEvent::HTTPD::Request';
  4         5  
  4         22  
393              
394             #
395             # AnyEvent::HTTPD::Request stores the form parameters in a peculiar format:
396             # $self->{parm} is a hashref of arrayrefs; each arrayref contain one
397             # or more values, again in arrayrefs with fixed number of items:
398             # [ content, content-type, file-name ]
399             #
400             # For anything but file uploads, the last 2 elements are undef; for the
401             # file uploads they're the file MIME type and name, respectively.
402             #
403             # A dump might look like this:
404             #
405             # $self->{parm}:
406             # 0 HASH
407             # 'formFieldName' => ARRAY
408             # 0 ARRAY =>
409             # 0 'form field value'
410             # 1 undef
411             # 2 undef
412             # 'fieldWithMultipleValues' => ARRAY # SURMISED!
413             # 0 ARRAY =>
414             # 0 'form field value 0'
415             # 1 undef
416             # 2 undef
417             # 1 ARRAY =>
418             # 0 'form field value 1'
419             # 1 undef
420             # 2 undef
421             # 'fileUploads' => ARRAY
422             # 0 ARRAY =>
423             # 0 'first file content (all of it!)'
424             # 1 'first file MIME type'
425             # 2 'first file name'
426             # 1 ARRAY =>
427             # 0 'second file content'
428             # 1 'second file MIME type'
429             # 2 'second file name'
430             #
431             # There is no method that returns multiple values for a non-file field,
432             # and no method that returns file upload parameters, so we have to
433             # roll our own
434             #
435              
436             sub param {
437 47     47   2597 my ($self, $key) = @_;
438            
439 47 100       95 return $self->params unless defined $key;
440            
441             # [] is to avoid autovivification biting my ass ;)
442 46 100       41 my @values = map { $_->[0] } @{ $self->{parm}->{$key} || [] };
  37         63  
  46         173  
443            
444 46 100       152 return wantarray ? @values : shift @values;
445             }
446              
447             # Go over the fields and return the list of names for the fields
448             # that contain file uploads
449             sub upload_fields {
450 2     2   4 my ($self) = @_;
451            
452 2         2 my @upload_fields;
453            
454 2         4 my $params = $self->{parm};
455            
456             FIELD:
457 2         6 for my $field_name ( keys %$params ) {
458 19         16 my $values = $params->{ $field_name };
459            
460 19         19 for my $value ( @$values ) {
461            
462             # We surmise that for a file upload, at least MIME type
463             # should be defined (name is optional)
464 19 100       41 if ( defined $value->[1] ) {
465 2         2 push @upload_fields, $field_name;
466 2         8 next FIELD;
467             }
468             }
469             }
470            
471 2         5 return @upload_fields;
472             }
473              
474             sub raw_param {
475 2     2   2 my ($self, $key) = @_;
476            
477 2         10 return $self->{parm}->{$key};
478             }
479              
480             sub cookie {
481 2     2   3327 my ($self, $key) = @_;
482              
483 2         5 my %cookies;
484              
485 2 50       6 if ( $self->{_cookies} ) {
486 0         0 %cookies = %{ $self->{_cookies} };
  0         0  
487             }
488             else {
489 2         12 my $headers = $self->headers;
490 2 50       14 my $cookie_hdr = $headers ? $headers->{cookie} : '';
491 2         10 %cookies = map { split /=/, $_ } split /;\s+/, $cookie_hdr;
  2         13  
492 2         7 $self->{_cookies} = \%cookies;
493             }
494              
495 2 100       17 return $key ? $cookies{ $key } : keys %cookies;
496             }
497              
498             sub http {
499 2     2   6782 my ($self, $key) = @_;
500              
501 2   50     15 my $headers = $self->headers || {};
502              
503 2 100       20 return $key ? $headers->{ lc $key } : keys %$headers;
504             }
505              
506             1;
507