File Coverage

blib/lib/Dash.pm
Criterion Covered Total %
statement 170 339 50.1
branch 27 116 23.2
condition 9 41 21.9
subroutine 22 34 64.7
pod 2 4 50.0
total 230 534 43.0


line stmt bran cond sub pod time code
1             package Dash;
2              
3 6     6   841534 use Moo;
  6         55642  
  6         33  
4 6     6   10306 use strictures 2;
  6         9803  
  6         236  
5 6     6   1205 use 5.020;
  6         20  
6              
7             our $VERSION = '0.10'; # VERSION
8              
9             # ABSTRACT: Analytical Web Apps in Perl (Port of Plotly's Dash to Perl)
10              
11             # TODO Enable signatures?
12              
13 6     6   3970 use JSON;
  6         63964  
  6         44  
14 6     6   882 use Scalar::Util;
  6         13  
  6         225  
15 6     6   2662 use Browser::Open;
  6         11557  
  6         274  
16 6     6   4722 use Path::Tiny;
  6         65691  
  6         330  
17 6     6   2581 use Dash::Renderer;
  6         19  
  6         202  
18 6     6   2321 use Dash::Config;
  6         19  
  6         227  
19 6     6   2883 use Dash::Exceptions::NoLayoutException;
  6         17  
  6         209  
20 6     6   2199 use Dash::Exceptions::PreventUpdate;
  6         30  
  6         197  
21 6     6   2501 use Dash::Backend::Mojolicious::App;
  6         22  
  6         65  
22 6     6   315 use namespace::clean;
  6         15  
  6         47  
23              
24             # TODO Add ci badges
25              
26             has app_name => ( is => 'ro',
27             default => __PACKAGE__ );
28              
29             has external_stylesheets => ( is => 'rw',
30             default => sub { [] } );
31              
32             has _layout => ( is => 'rw',
33             default => sub { {} } );
34              
35             has _callbacks => ( is => 'rw',
36             default => sub { {} } );
37              
38             has _rendered_scripts => ( is => 'rw',
39             default => "" );
40              
41             has _rendered_external_stylesheets => ( is => 'rw',
42             default => "" );
43              
44             has backend => ( is => 'rw',
45             default => sub { Dash::Backend::Mojolicious::App->new( dash_app => shift ) } );
46              
47             has config => ( is => 'rw',
48             default => sub { Dash::Config->new() } );
49              
50             sub layout {
51 13     13 1 3026 my $self = shift;
52 13         24 my $layout = shift;
53 13 100       39 if ( defined $layout ) {
54 11         25 my $type = ref $layout;
55 11 100 66     109 if ( $type eq 'CODE' || ( Scalar::Util::blessed($layout) && $layout->isa('Dash::BaseComponent') ) ) {
      66        
56 9         45 $self->_layout($layout);
57             } else {
58 2         17 Dash::Exceptions::NoLayoutException->throw(
59             'Layout must be a dash component or a function that returns a dash component');
60             }
61             } else {
62 2         12 $layout = $self->_layout;
63             }
64 11         46 return $layout;
65             }
66              
67             sub callback {
68 8     8 1 156 my $self = shift;
69 8         24 my %callback = $self->_process_callback_arguments(@_);
70              
71             # TODO check_callback
72             # TODO Callback map
73 8         19 my $output = $callback{Output};
74 8         23 my $callback_id = $self->_create_callback_id($output);
75 8         43 my $callbacks = $self->_callbacks;
76 8         20 $callbacks->{$callback_id} = \%callback;
77 8         21 return $self;
78             }
79              
80             my $no_update;
81             my $internal_no_update = bless( \$no_update, 'Dash::Internal::NoUpdate' );
82              
83             sub no_update {
84 0     0 0 0 return $internal_no_update;
85             }
86              
87             sub _process_callback_arguments {
88 8     8   15 my $self = shift;
89              
90 8         13 my %callback;
91              
92             # 1. all refs: 1 blessed, 1 array, 1 code or 2 array, 1 code
93             # Hash with keys Output, Inputs, callback
94             # 2. Values content: hashref or arrayref[hashref], arrayref[hashref], coderef
95             # 3. Values content: blessed output or arrayref[blessed], arrayref[blessed], coderef
96              
97 8 50       22 if ( scalar @_ < 5 ) { # Unamed arguments, put names
98 0         0 my ( $output_index, $input_index, $state_index, $callback_index );
99              
100 0         0 my $index = 0;
101 0         0 for my $argument (@_) {
102 0         0 my $type = ref $argument;
103 0 0       0 if ( $type eq 'CODE' ) {
    0          
    0          
    0          
    0          
    0          
104 0         0 $callback_index = $index;
105             } elsif ( Scalar::Util::blessed $argument) {
106 0 0       0 if ( $argument->isa('Dash::Dependencies::Output') ) {
107 0         0 $output_index = $index;
108             }
109             } elsif ( $type eq 'ARRAY' ) {
110 0 0       0 if ( scalar @$argument > 0 ) {
111 0         0 my $first_element = $argument->[0];
112 0 0       0 if ( Scalar::Util::blessed $first_element) {
113 0 0       0 if ( $first_element->isa('Dash::Dependencies::Output') ) {
    0          
    0          
114 0         0 $output_index = $index;
115             } elsif ( $first_element->isa('Dash::Dependencies::Input') ) {
116 0         0 $input_index = $index;
117             } elsif ( $first_element->isa('Dash::Dependencies::State') ) {
118 0         0 $state_index = $index;
119             }
120             }
121             } else {
122 0         0 die "Can't use empty arrayrefs as arguments";
123             }
124             } elsif ( $type eq 'SCALAR' ) {
125 0         0 die
126             "Can't mix scalarref arguments with objects when not using named paremeters. Please use named parameters for all arguments or classes for all arguments";
127             } elsif ( $type eq 'HASH' ) {
128 0         0 die
129             "Can't mix hashref arguments with objects when not using named parameters. Please use named parameters for all arguments or classes for all arguments";
130             } elsif ( $type eq '' ) {
131 0         0 die
132             "Can't mix scalar arguments with objects when not using named parameters. Please use named parameters for all arguments or classes for all arguments";
133             }
134 0         0 $index++;
135             }
136 0 0       0 if ( !defined $output_index ) {
137 0         0 die "Can't find callback output";
138             }
139 0 0       0 if ( !defined $input_index ) {
140 0         0 die "Can't find callback inputs";
141             }
142 0 0       0 if ( !defined $callback_index ) {
143 0         0 die "Can't find callback function";
144             }
145              
146 0         0 $callback{Output} = $_[$output_index];
147 0         0 $callback{Inputs} = $_[$input_index];
148 0         0 $callback{callback} = $_[$callback_index];
149 0 0       0 if ( defined $state_index ) {
150 0         0 $callback{State} = $_[$state_index];
151             }
152             } else { # Named arguments
153             # TODO check keys ¿Params::Validate or similar?
154 8         39 %callback = @_;
155             }
156              
157             # Convert Output & input to hashrefs
158 8         28 for my $key ( keys %callback ) {
159 26         41 my $value = $callback{$key};
160              
161 26 100       84 if ( ref $value eq 'ARRAY' ) {
    50          
162 12         18 my @hashes;
163 12         21 for my $dependency (@$value) {
164 14 50       33 if ( Scalar::Util::blessed $dependency) {
165 0         0 my %dependency_hash = %$dependency;
166 0         0 push @hashes, \%dependency_hash;
167             } else {
168 14         32 push @hashes, $dependency;
169             }
170             }
171 12         25 $callback{$key} = \@hashes;
172             } elsif ( Scalar::Util::blessed $value) {
173 0         0 my %dependency_hash = %$value;
174 0         0 $callback{$key} = \%dependency_hash;
175             }
176             }
177              
178 8         39 return %callback;
179             }
180              
181             sub _create_callback_id {
182 8     8   13 my $self = shift;
183 8         11 my $output = shift;
184              
185 8 100       22 if ( ref $output eq 'ARRAY' ) {
186 2         6 return ".." . join( "...", map { $_->{component_id} . "." . $_->{component_property} } @$output ) . "..";
  4         20  
187             }
188              
189 6         22 return $output->{component_id} . "." . $output->{component_property};
190             }
191              
192             sub run_server {
193 0     0 0 0 my $self = shift;
194              
195 0         0 $self->_render_and_cache_scripts();
196 0         0 $self->_render_and_cache_external_stylesheets();
197              
198             # Opening the browser before starting the daemon works because
199             # open_browser returns inmediately
200             # TODO Open browser optional
201 0 0       0 if ( not caller(1) ) {
202 0         0 Browser::Open::open_browser('http://127.0.0.1:8080');
203 0         0 $self->backend->start( 'daemon', '-l', 'http://*:8080' );
204             }
205 0         0 return $self->backend;
206             }
207              
208             sub _dependencies {
209 4     4   26 my $self = shift;
210 4         8 my $dependencies = [];
211 4         10 for my $callback ( values %{ $self->_callbacks } ) {
  4         19  
212 3         10 my $rendered_callback = { clientside_function => JSON::null };
213 3         14 my $states = [];
214 3         4 for my $state ( @{ $callback->{State} } ) {
  3         10  
215             my $rendered_state = { id => $state->{component_id},
216             property => $state->{component_property}
217 1         51 };
218 1         5 push @$states, $rendered_state;
219             }
220 3         7 $rendered_callback->{state} = $states;
221 3         5 my $inputs = [];
222 3         5 for my $input ( @{ $callback->{Inputs} } ) {
  3         5  
223             my $rendered_input = { id => $input->{component_id},
224             property => $input->{component_property}
225 3         10 };
226 3         6 push @$inputs, $rendered_input;
227             }
228 3         5 $rendered_callback->{inputs} = $inputs;
229 3         7 my $output_type = ref $callback->{Output};
230 3 100       9 if ( $output_type eq 'ARRAY' ) {
    50          
231 1         4 $rendered_callback->{'output'} .= '.';
232 1         2 for my $output ( @{ $callback->{'Output'} } ) {
  1         3  
233             $rendered_callback->{'output'} .=
234 2         7 '.' . join( '.', $output->{component_id}, $output->{component_property} ) . '..';
235             }
236             } elsif ( $output_type eq 'HASH' ) {
237             $rendered_callback->{'output'} =
238 2         11 join( '.', $callback->{'Output'}{component_id}, $callback->{'Output'}{component_property} );
239             } else {
240 0         0 die 'Dependecy type for callback not implemented';
241             }
242 3         7 push @$dependencies, $rendered_callback;
243             }
244 4         21 return $dependencies;
245             }
246              
247             sub _update_component {
248 6     6   149 my $self = shift;
249 6         10 my $request = shift;
250              
251 6 100       9 if ( scalar( values %{ $self->_callbacks } ) > 0 ) {
  6         31  
252 5         18 my $callbacks = $self->_search_callback( $request->{'output'} );
253 5 50       21 if ( scalar @$callbacks > 1 ) {
    50          
254 0         0 die 'Not implemented multiple callbacks';
255             } elsif ( scalar @$callbacks == 1 ) {
256 5         8 my $callback = $callbacks->[0];
257 5         8 my @callback_arguments = ();
258 5         10 my $callback_context = {};
259 5         7 for my $callback_input ( @{ $callback->{Inputs} } ) {
  5         13  
260 5         10 my ( $component_id, $component_property ) = @{$callback_input}{qw(component_id component_property)};
  5         12  
261 5         9 for my $change_input ( @{ $request->{inputs} } ) {
  5         11  
262 5         70 my ( $id, $property, $value ) = @{$change_input}{qw(id property value)};
  5         18  
263 5 50 33     33 if ( $component_id eq $id && $component_property eq $property ) {
264 5         12 push @callback_arguments, $value;
265 5         20 $callback_context->{inputs}{ $id . "." . $property } = $value;
266 5         17 last;
267             }
268             }
269             }
270 5         59 for my $callback_input ( @{ $callback->{State} } ) {
  5         16  
271 1         2 my ( $component_id, $component_property ) = @{$callback_input}{qw(component_id component_property)};
  1         14  
272 1         3 for my $change_input ( @{ $request->{state} } ) {
  1         3  
273 1         3 my ( $id, $property, $value ) = @{$change_input}{qw(id property value)};
  1         4  
274 1 50 33     7 if ( $component_id eq $id && $component_property eq $property ) {
275 1         3 push @callback_arguments, $value;
276 1         4 $callback_context->{states}{ $id . "." . $property } = $value;
277 1         3 last;
278             }
279             }
280             }
281              
282 5         30 $callback_context->{triggered} = [];
283 5         8 for my $triggered_input ( @{ $request->{changedPropIds} } ) {
  5         14  
284 5         32 push @{ $callback_context->{triggered} },
285             { prop_id => $triggered_input,
286 5         7 value => $callback_context->{inputs}{$triggered_input}
287             };
288             }
289 5         11 push @callback_arguments, $callback_context;
290              
291 5         12 my $output_type = ref $callback->{Output};
292 5 100       20 if ( $output_type eq 'ARRAY' ) {
    50          
293 1         5 my @return_value = $callback->{callback}(@callback_arguments);
294 1         7 my $props_updated = {};
295 1         3 my $index_output = 0;
296 1         2 my $some_updated = 0;
297 1         2 for my $output ( @{ $callback->{'Output'} } ) {
  1         3  
298 2         4 my $output_value = $return_value[ $index_output++ ];
299 2 50 33     15 if ( !( Scalar::Util::blessed($output_value) && $output_value->isa('Dash::Internal::NoUpdate') ) ) {
300             $props_updated->{ $output->{component_id} } =
301 2         14 { $output->{component_property} => $output_value };
302 2         5 $some_updated = 1;
303             }
304             }
305 1 50       3 if ($some_updated) {
306 1         10 return { response => $props_updated, multi => JSON::true };
307             } else {
308 0         0 Dash::Exceptions::PreventUpdate->throw;
309             }
310             } elsif ( $output_type eq 'HASH' ) {
311 4         12 my $updated_value = $callback->{callback}(@callback_arguments);
312 3 50 33     30 if ( Scalar::Util::blessed($updated_value) && $updated_value->isa('Dash::Internal::NoUpdate') ) {
313 0         0 Dash::Exceptions::PreventUpdate->throw;
314             }
315 3         12 my $updated_property = ( split( /\./, $request->{output} ) )[-1];
316 3         9 my $props_updated = { $updated_property => $updated_value };
317 3         29 return { response => { props => $props_updated } };
318             } else {
319 0         0 die 'Callback not supported';
320             }
321             } else {
322 0         0 return { response => "There is no matching callback" };
323             }
324              
325             } else {
326 1         6 return { response => "There is no registered callbacks" };
327             }
328 0         0 return { response => "Internal error" };
329             }
330              
331             sub _search_callback {
332 5     5   8 my $self = shift;
333 5         16 my $output = shift;
334              
335 5         11 my $callbacks = $self->_callbacks;
336 5         14 my @matching_callbacks = ( $callbacks->{$output} );
337 5         12 return \@matching_callbacks;
338             }
339              
340             sub _rendered_stylesheets {
341 1     1   11 return '';
342             }
343              
344             sub _render_external_stylesheets {
345 0     0   0 my $self = shift;
346 0         0 my $stylesheets = $self->external_stylesheets;
347 0         0 my $rendered_external_stylesheets = "";
348 0         0 for my $stylesheet (@$stylesheets) {
349 0         0 $rendered_external_stylesheets .= '' . "\n";
350             }
351 0         0 return $rendered_external_stylesheets;
352             }
353              
354             sub _render_and_cache_external_stylesheets {
355 0     0   0 my $self = shift;
356 0         0 my $stylesheets = $self->_render_external_stylesheets();
357 0         0 $self->_rendered_external_stylesheets($stylesheets);
358             }
359              
360             sub _render_and_cache_scripts {
361 0     0   0 my $self = shift;
362 0         0 my $scripts = $self->_render_scripts();
363 0         0 $self->_rendered_scripts($scripts);
364             }
365              
366             sub _render_dash_config {
367 0     0   0 my $self = shift;
368 0         0 my $json = JSON->new->utf8->allow_blessed->convert_blessed;
369 0         0 return '';
370             }
371              
372             sub _dash_renderer_js_dependencies {
373 0     0   0 my $js_dist_dependencies = Dash::Renderer::_js_dist_dependencies();
374 0         0 my @js_deps = ();
375 0         0 for my $deps (@$js_dist_dependencies) {
376 0         0 my $external_url = $deps->{external_url};
377 0         0 my $relative_package_path = $deps->{relative_package_path};
378 0         0 my $namespace = $deps->{namespace};
379 0         0 my $dep_count = 0;
380 0         0 for my $dep ( @{ $relative_package_path->{prod} } ) {
  0         0  
381             my $js_dep = { namespace => $namespace,
382             relative_package_path => $dep,
383             dev_package_path => $relative_package_path->{dev}[$dep_count],
384 0         0 external_url => $external_url->{prod}[$dep_count]
385             };
386 0         0 push @js_deps, $js_dep;
387 0         0 $dep_count++;
388             }
389             }
390 0         0 \@js_deps;
391             }
392              
393             sub _dash_renderer_js_deps {
394 0     0   0 return Dash::Renderer::_js_dist();
395             }
396              
397             sub _render_dash_renderer_script {
398 0     0   0 return '';
399             }
400              
401             sub _render_scripts {
402 0     0   0 my $self = shift;
403              
404             # First dash_renderer dependencies
405 0         0 my $scripts_dependencies = $self->_dash_renderer_js_dependencies;
406              
407             # Traverse layout and recover javascript dependencies
408             # TODO auto register dependencies on component creation to avoid traversing and filter too much dependencies
409 0         0 my $layout = $self->layout;
410              
411 0         0 my $visitor;
412 0         0 my $stack_depth_limit = 1000;
413             $visitor = sub {
414 0     0   0 my $node = shift;
415 0         0 my $stack_depth = shift;
416 0 0       0 if ( $stack_depth++ >= $stack_depth_limit ) {
417              
418             # TODO warn user that layout is too deep
419 0         0 return;
420             }
421 0         0 my $type = ref $node;
422 0 0       0 if ( $type eq 'HASH' ) {
    0          
    0          
423 0         0 for my $key ( keys %$node ) {
424 0         0 $visitor->( $node->{$key}, $stack_depth );
425             }
426             } elsif ( $type eq 'ARRAY' ) {
427 0         0 for my $element (@$node) {
428 0         0 $visitor->( $element, $stack_depth );
429             }
430             } elsif ( $type ne '' ) {
431 0         0 my $node_dependencies = $node->_js_dist();
432 0 0       0 push @$scripts_dependencies, @$node_dependencies if defined $node_dependencies;
433 0 0       0 if ( $node->can('children') ) {
434 0         0 $visitor->( $node->children, $stack_depth );
435             }
436             }
437 0         0 };
438              
439 0         0 $visitor->( $layout, 0 );
440              
441 0         0 my $rendered_scripts = "";
442 0         0 $rendered_scripts .= $self->_render_dash_config();
443 0         0 push @$scripts_dependencies, @{ $self->_dash_renderer_js_deps() };
  0         0  
444 0         0 my $filtered_resources = $self->_filter_resources($scripts_dependencies);
445 0         0 my %rendered = ();
446 0         0 for my $dep (@$filtered_resources) {
447 0   0     0 my $dynamic = $dep->{dynamic} // 0;
448 0 0       0 if ( !$dynamic ) {
449 0         0 my $resource_path_part = join( "/", $dep->{namespace}, $dep->{relative_package_path} );
450 0 0       0 if ( !$rendered{$resource_path_part} ) {
451 0         0 $rendered_scripts .=
452             '' . "\n";
453 0         0 $rendered{$resource_path_part} = 1;
454             }
455             }
456             }
457 0         0 $rendered_scripts .= $self->_render_dash_renderer_script();
458              
459 0         0 return $rendered_scripts;
460             }
461              
462             sub _filter_resources {
463 0     0   0 my $self = shift;
464 0         0 my $resources = shift;
465 0         0 my %params = @_;
466 0   0     0 my $dev_bundles = $params{dev_bundles} // 0;
467 0   0     0 my $eager_loading = $params{eager_loading} // 0;
468 0   0     0 my $serve_locally = $params{serve_locally} // 1;
469              
470 0         0 my $filtered_resources = [];
471 0         0 for my $resource (@$resources) {
472 0         0 my $filtered_resource = {};
473 0         0 my $dynamic = $resource->{dynamic};
474 0 0       0 if ( defined $dynamic ) {
475 0         0 $filtered_resource->{dynamic} = $dynamic;
476             }
477 0         0 my $async = $resource->{async};
478 0 0       0 if ( defined $async ) {
479 0 0       0 if ( defined $dynamic ) {
480 0         0 die "A resource can't have both dynamic and async: " + to_json($resource);
481             }
482 0         0 my $dynamic = 1;
483 0 0       0 if ( $async eq 'lazy' ) {
484 0         0 $dynamic = 1;
485             } else {
486 0 0 0     0 if ( $async eq 'eager' && !$eager_loading ) {
487 0         0 $dynamic = 1;
488             } else {
489 0 0 0     0 if ( $async && !$eager_loading ) {
490 0         0 $dynamic = 1;
491             } else {
492 0         0 $dynamic = 0;
493             }
494             }
495             }
496 0         0 $filtered_resource->{dynamic} = $dynamic;
497             }
498 0         0 my $namespace = $resource->{namespace};
499 0 0       0 if ( defined $namespace ) {
500 0         0 $filtered_resource->{namespace} = $namespace;
501             }
502 0         0 my $external_url = $resource->{external_url};
503 0 0 0     0 if ( defined $external_url && !$serve_locally ) {
504 0         0 $filtered_resource->{external_url} = $external_url;
505             } else {
506 0         0 my $dev_package_path = $resource->{dev_package_path};
507 0 0 0     0 if ( defined $dev_package_path && $dev_bundles ) {
508 0         0 $filtered_resource->{relative_package_path} = $dev_package_path;
509             } else {
510 0         0 my $relative_package_path = $resource->{relative_package_path};
511 0 0       0 if ( defined $relative_package_path ) {
512 0         0 $filtered_resource->{relative_package_path} = $relative_package_path;
513             } else {
514 0         0 my $absolute_path = $resource->{absolute_path};
515 0 0       0 if ( defined $absolute_path ) {
516 0         0 $filtered_resource->{absolute_path} = $absolute_path;
517             } else {
518 0         0 my $asset_path = $resource->{asset_path};
519 0 0       0 if ( defined $asset_path ) {
520 0         0 my $stat_info = path( $resource->{filepath} )->stat;
521 0         0 $filtered_resource->{asset_path} = $asset_path;
522 0         0 $filtered_resource->{ts} = $stat_info->mtime;
523             } else {
524 0 0       0 if ($serve_locally) {
525 0         0 warn
526             'There is no local version of this resource. Please consider using external_scripts or external_stylesheets : '
527             + to_json($resource);
528 0         0 next;
529             } else {
530 0         0 die
531             'There is no relative_package-path, absolute_path or external_url for this resource : '
532             + to_json($resource);
533             }
534             }
535             }
536             }
537             }
538             }
539              
540 0         0 push @$filtered_resources, $filtered_resource;
541             }
542 0         0 return $filtered_resources;
543             }
544              
545             sub _filename_from_file_with_fingerprint {
546 1     1   22 my $self = shift;
547 1         3 my $file = shift;
548 1         17 my @path_parts = split( /\//, $file );
549 1         6 my @name_parts = split( /\./, $path_parts[-1] );
550              
551             # Check if the resource has a fingerprint
552 1 50 33     10 if ( ( scalar @name_parts ) > 2 && $name_parts[1] =~ /^v[\w-]+m[0-9a-fA-F]+$/ ) {
553 0         0 my $original_name = join( ".", $name_parts[0], @name_parts[ 2 .. ( scalar @name_parts - 1 ) ] );
554 0         0 $file = join( "/", @path_parts[ 0 .. ( scalar @path_parts - 2 ) ], $original_name );
555             }
556              
557 1         6 return $file;
558             }
559              
560             1;
561              
562             __END__