bcd7622eff030bc197b01ace007a9f471a924e76
[Evergreen.git] / Open-ILS / src / reporter / clark-kent.pl
1 #!/usr/bin/perl -w
2
3 use strict;
4 use DBI;
5 use FileHandle;
6 use XML::LibXML;
7 use Getopt::Long;
8 use DateTime;
9 use DateTime::Format::ISO8601;
10 use JSON;
11 use Data::Dumper;
12 use OpenILS::WWW::Reporter::transforms;
13 use Text::CSV_XS;
14 use Spreadsheet::WriteExcel;
15 use OpenSRF::EX qw/:try/;
16 use OpenSRF::Utils qw/:daemon/;
17 use OpenSRF::Utils::Logger qw/:level/;
18 use POSIX;
19 use GD::Graph::pie;
20 use GD::Graph::bars3d;
21 use GD::Graph::lines;
22
23 use open ':utf8';
24
25 my $current_time = DateTime->from_epoch( epoch => time() )->strftime('%FT%T%z');
26
27 my ($base_xml, $count, $daemon) = ('/openils/conf/reporter.xml', 1);
28
29 GetOptions(
30         "file=s"        => \$base_xml,
31         "daemon"        => \$daemon,
32         "concurrency=i" => \$count,
33 );
34
35 my $parser = XML::LibXML->new;
36 $parser->expand_xinclude(1);
37
38 my $doc = $parser->parse_file($base_xml);
39
40 my $db_driver = $doc->findvalue('/reporter/setup/database/driver');
41 my $db_host = $doc->findvalue('/reporter/setup/database/host');
42 my $db_name = $doc->findvalue('/reporter/setup/database/name');
43 my $db_user = $doc->findvalue('/reporter/setup/database/user');
44 my $db_pw = $doc->findvalue('/reporter/setup/database/password');
45
46 my $dsn = "dbi:" . $db_driver . ":dbname=" . $db_name .';host=' . $db_host;
47
48 my $dbh;
49
50 daemonize("Clark Kent, waiting for trouble") if ($daemon);
51
52 DAEMON:
53
54 $dbh = DBI->connect($dsn,$db_user,$db_pw, {pg_enable_utf8 => 1, RaiseError => 1});
55
56 # Move new reports into the run queue
57 $dbh->do(<<'SQL', {}, $current_time);
58 INSERT INTO reporter.output ( stage3, state ) 
59         SELECT  id, 'wait'
60           FROM  reporter.stage3 
61           WHERE runtime <= $1
62                 AND (   (       recurrence = '0 seconds'::INTERVAL
63                                 AND id NOT IN ( SELECT stage3 FROM reporter.output ) )
64                         OR (    recurrence > '0 seconds'::INTERVAL
65                                 AND id NOT IN (
66                                         SELECT  stage3
67                                           FROM  reporter.output
68                                           WHERE state <> 'complete')
69                         )
70                 )
71           ORDER BY runtime;
72 SQL
73
74 # make sure we're not already running $count reports
75 my ($running) = $dbh->selectrow_array(<<SQL);
76 SELECT  count(*)
77   FROM  reporter.output
78   WHERE state = 'running';
79 SQL
80
81 if ($count <= $running) {
82         if ($daemon) {
83                 $dbh->disconnect;
84                 sleep 1;
85                 POSIX::waitpid( -1, POSIX::WNOHANG );
86                 sleep 60;
87                 goto DAEMON;
88         }
89         print "Already running maximum ($running) concurrent reports\n";
90         exit 1;
91 }
92
93 # if we have some open slots then generate the sql
94 my $run = $count - $running;
95
96 my $sth = $dbh->prepare(<<SQL);
97 SELECT  *
98   FROM  reporter.output
99   WHERE state = 'wait'
100   ORDER BY queue_time
101   LIMIT $run;
102 SQL
103
104 $sth->execute;
105
106 my @reports;
107 while (my $r = $sth->fetchrow_hashref) {
108         my $s3 = $dbh->selectrow_hashref(<<"    SQL", {}, $r->{stage3});
109                 SELECT * FROM reporter.stage3 WHERE id = ?;
110         SQL
111
112         my $s2 = $dbh->selectrow_hashref(<<"    SQL", {}, $s3->{stage2});
113                 SELECT * FROM reporter.stage2 WHERE id = ?;
114         SQL
115
116         $s3->{stage2} = $s2;
117         $r->{stage3} = $s3;
118
119         generate_query( $r );
120         push @reports, $r;
121 }
122
123 $sth->finish;
124
125 $dbh->disconnect;
126
127 # Now we spaun the report runners
128
129 for my $r ( @reports ) {
130         next if (safe_fork());
131
132         # This is the child (runner) process;
133         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
134         daemonize("Clark Kent reporting: $p->{reportname}");
135
136         $dbh = DBI->connect($dsn,$db_user,$db_pw, {pg_enable_utf8 => 1, RaiseError => 1});
137
138         try {
139                 $dbh->do(<<'            SQL',{}, $r->{sql}->{'select'}, $$, $r->{id});
140                         UPDATE  reporter.output
141                           SET   state = 'running',
142                                 run_time = 'now',
143                                 query = ?,
144                                 run_pid = ?
145                           WHERE id = ?;
146                 SQL
147
148                 $sth = $dbh->prepare($r->{sql}->{'select'});
149
150                 $sth->execute(@{ $r->{sql}->{'bind'} });
151                 $r->{data} = $sth->fetchall_arrayref;
152
153                 my $base = $doc->findvalue('/reporter/setup/files/output_base');
154                 my $s1 = $r->{stage3}->{stage2}->{stage1};
155                 my $s2 = $r->{stage3}->{stage2}->{id};
156                 my $s3 = $r->{stage3}->{id};
157                 my $output = $r->{id};
158
159                 mkdir($base);
160                 mkdir("$base/$s1");
161                 mkdir("$base/$s1/$s2");
162                 mkdir("$base/$s1/$s2/$s3");
163                 mkdir("$base/$s1/$s2/$s3/$output");
164         
165                 my @formats;
166                 if (ref $p->{output_format}) {
167                         @formats = @{ $p->{output_format} };
168                 } else {
169                         @formats = ( $p->{output_format} );
170                 }
171         
172                 if ( grep { $_ eq 'csv' } @formats ) {
173                         build_csv("$base/$s1/$s2/$s3/$output/report-data.csv", $r);
174                 }
175                 
176                 if ( grep { $_ eq 'excel' } @formats ) {
177                         build_excel("$base/$s1/$s2/$s3/$output/report-data.xls", $r);
178                 }
179                 
180                 if ( grep { $_ eq 'html' } @formats ) {
181                         mkdir("$base/$s1/$s2/$s3/$output/html");
182                         build_html("$base/$s1/$s2/$s3/$output/report-data.html", $r);
183                 }
184
185
186                 $dbh->begin_work;
187                 $dbh->do(<<'            SQL',{}, $r->{stage3}->{id});
188                         UPDATE  reporter.stage3
189                           SET   runtime = runtime + recurrence
190                           WHERE id = ? AND recurrence > '0 seconds'::INTERVAL;
191                 SQL
192                 $dbh->do(<<'            SQL',{}, $r->{id});
193                         UPDATE  reporter.output
194                           SET   state = 'complete',
195                                 complete_time = 'now'
196                           WHERE id = ?;
197                 SQL
198                 $dbh->commit;
199
200
201         } otherwise {
202                 my $e = shift;
203                 $dbh->rollback;
204                 $dbh->do(<<'            SQL',{}, $e, $r->{id});
205                         UPDATE  reporter.output
206                           SET   state = 'error',
207                                 error_time = 'now',
208                                 error = ?,
209                                 run_pid = NULL
210                           WHERE id = ?;
211                 SQL
212         };
213
214         $dbh->disconnect;
215
216         exit; # leave the child
217 }
218
219 if ($daemon) {
220         sleep 1;
221         POSIX::waitpid( -1, POSIX::WNOHANG );
222         sleep 60;
223         goto DAEMON;
224 }
225
226 #-------------------------------------------------------------------
227
228 sub build_csv {
229         my $file = shift;
230         my $r = shift;
231
232         my $csv = Text::CSV_XS->new({ always_quote => 1, eol => "\015\012" });
233         my $f = new FileHandle (">$file");
234
235         $csv->print($f, $r->{sql}->{columns});
236         $csv->print($f, $_) for (@{$r->{data}});
237
238         $f->close;
239 }
240 sub build_excel {
241         my $file = shift;
242         my $r = shift;
243         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
244
245         my $xls = Spreadsheet::WriteExcel->new($file);
246
247         my $sheetname = substr($p->{reportname},1,31);
248         $sheetname =~ s/\W/_/gos;
249         
250         my $sheet = $xls->add_worksheet($sheetname);
251
252         $sheet->write_row('A1', $r->{sql}->{columns});
253
254         $sheet->write_col('A2', $r->{data});
255
256         $xls->close;
257 }
258
259 sub build_html {
260         my $file = shift;
261         my $r = shift;
262         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
263
264         my $index = new FileHandle (">$file");
265         my $raw = new FileHandle (">$file.raw.html");
266         
267         # index header
268         print $index <<"        HEADER";
269 <html>
270         <head>
271                 <title>$$p{reportname}</title>
272                 <style>
273                         table { border-collapse: collapse; }
274                         th { background-color: lightgray; }
275                         td,th { border: solid black 1px; }
276                         * { font-family: sans-serif; font-size: 10px; }
277                 </style>
278         </head>
279         <body>
280                 <h2><u>$$p{reportname}</u></h2>
281         HEADER
282
283         
284         # add a link to the raw output html
285         print $index "<a href='report-data.html.raw.html'>Raw output data</a><br/><br/><br/><br/>";
286
287         # create the raw output html file
288         print $raw "<html><head><title>$$p{reportname}</title>";
289
290         print $raw <<'  CSS';
291                 <style>
292                         table { border-collapse: collapse; }
293                         th { background-color: lightgray; }
294                         td,th { border: solid black 1px; }
295                         * { font-family: sans-serif; font-size: 10px; }
296                 </style>
297         CSS
298
299         print $raw "</head><body><table>";
300         print $raw "<tr><th>".join('</th><th>',@{$r->{sql}->{columns}}).'</th></tr>';
301
302         print $raw "<tr><td>".join('</td><td>',@$_).'</td></tr>' for (@{$r->{data}});
303
304         print $raw '</table></body></html>';
305         
306         $raw->close;
307
308         # get the graph types
309         my @graphs;
310         if (ref $$p{html_graph_type}) {
311                 @graphs = @{ $$p{html_graph_type} };
312         } else {
313                 @graphs = ( $$p{html_graph_type} );
314         }
315
316         # Time for a pie chart
317         if (grep {$_ eq 'pie'} @graphs) {
318                 my $pics = draw_pie($r, $p, $file);
319                 for my $pic (@$pics) {
320                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
321                 }
322         }
323
324         # Time for a bar chart
325         if (grep {$_ eq 'bar'} @graphs) {
326                 my $pics = draw_bars($r, $p, $file);
327                 for my $pic (@$pics) {
328                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
329                 }
330         }
331
332
333         # and that's it!
334         print $index '</body></html>';
335         
336         $index->close;
337 }
338
339 sub draw_pie {
340         my $r = shift;
341         my $p = shift;
342         my $file = shift;
343         my $data = $r->{data};
344         my $settings = $r->{sql};
345
346         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
347         
348         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
349         delete @values[@groups];
350         
351         my @pics;
352         for my $vcol (@values) {
353                 next unless (defined $vcol);
354
355                 my @pic_data;
356                 for my $row (@$data) {
357                         next if ($$row[$vcol] == 0);
358                         push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
359                         push @{$pic_data[1]}, $$row[$vcol];
360                 }
361
362                 my $pic = new GD::Graph::pie;
363
364                 $pic->set(
365                         label           => $p->{reportname}." -- ".$settings->{columns}->[$vcol],
366                         start_angle     => 180,
367                         legend_placement=> 'R'
368                 );
369
370                 my $format = $pic->export_format;
371
372                 open(IMG, ">$file.pie.$vcol.$format");
373                 binmode IMG;
374
375                 my $forgetit = 0;
376                 try {
377                         $pic->plot(\@pic_data) or die $pic->error;
378                         print IMG $pic->gd->$format;
379                 } otherwise {
380                         my $e = shift;
381                         warn "Couldn't draw $file.pie.$vcol.$format : $e";
382                         $forgetit = 1;
383                 };
384
385                 close IMG;
386
387                 next if ($forgetit);
388
389                 push @pics,
390                         { file => "pie.$vcol.$format",
391                           name => $p->{reportname}." -- ".$settings->{columns}->[$vcol].' (Pie)',
392                         };
393
394         }
395         
396         return \@pics;
397 }
398
399 sub draw_bars {
400         my $r = shift;
401         my $p = shift;
402         my $file = shift;
403         my $data = $r->{data};
404         my $settings = $r->{sql};
405
406         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
407         
408         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
409         delete @values[@groups];
410         
411         my @pic_data;
412         for my $row (@$data) {
413                 push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
414         }
415
416         my @leg;
417         my $set = 1;
418
419         my %trim_candidates;
420
421         my $max_y = 0;
422         for my $vcol (@values) {
423                 next unless (defined $vcol);
424
425                 push @leg, $settings->{columns}->[$vcol];
426
427                 my $pos = 0;
428                 for my $row (@$data) {
429                         my $val = $$row[$vcol] ? $$row[$vcol] : 0;
430                         push @{$pic_data[$set]}, $val;
431                         $max_y = $val if ($val > $max_y);
432                         $trim_candidates{$pos}++ if ($val == 0);
433                         $pos++;
434                 }
435
436                 $set++;
437         }
438         my $set_count = scalar(@pic_data) - 1;
439         my @trim_cols = grep { $trim_candidates{$_} == $set_count } keys %trim_candidates;
440
441         for my $dataset (@pic_data) {
442                 for my $col (reverse sort { $a <=> $b } @trim_cols) {
443                         splice(@$dataset,$col,1);
444                 }
445         }
446
447         my $w = 100 + 10 * scalar(@{$pic_data[0]});
448         $w = 400 if ($w < 400);
449
450         my $pic = new GD::Graph::bars3d ($w, 500);
451
452         $pic->set(
453                 title                   => $p->{reportname},
454                 x_labels_vertical       => 1,
455                 shading                 => 1,
456                 bar_depth               => 5,
457                 bar_spacing             => 2,
458                 y_max_value             => $max_y,
459                 legend_placement        => 'BL',
460                 boxclr                  => 'lgray',
461         );
462         $pic->set_legend(@leg);
463
464         my $format = $pic->export_format;
465
466         open(IMG, ">$file.bar.$format");
467         binmode IMG;
468
469         my $forgetit = 0;
470         try {
471                 $pic->plot(\@pic_data) or die $pic->error;
472                 print IMG $pic->gd->$format;
473         } otherwise {
474                 my $e = shift;
475                 warn "Couldn't draw $file.bar.$format : $e";
476                 $forgetit = 1;
477         };
478
479         close IMG;
480
481         next if ($forgetit);
482
483         return [{ file => "bar.$format",
484                   name => $p->{reportname}.' (Bar)',
485                 }];
486
487 }
488
489 sub table_by_id {
490         my $id = shift;
491         my ($node) = $doc->findnodes("//*[\@id='$id']");
492         if ($node && $node->findvalue('@table')) {
493                 ($node) = $doc->findnodes("//*[\@id='".$node->getAttribute('table')."']");
494         }
495         return $node;
496 }
497
498 sub generate_query {
499         my $r = shift;
500
501         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
502
503         my @group_by;
504         my @aggs;
505         my $core = $r->{stage3}->{stage2}->{stage1};
506         my @dims;
507
508         for my $t (keys %{$$p{filter}}) {
509                 if ($t ne $core) {
510                         push @dims, $t;
511                 }
512         }
513
514         for my $t (keys %{$$p{output}}) {
515                 if ($t ne $core && !grep { $t } @dims ) {
516                         push @dims, $t;
517                 }
518         }
519
520         my @dim_select;
521         my @dim_from;
522         for my $d (@dims) {
523                 my $t = table_by_id($d);
524                 my $t_name = $t->findvalue('tablename');
525                 push @dim_from, "$t_name AS \"$d\"";
526
527                 my $k = $doc->findvalue("//*[\@id='$d']/\@key");
528                 push @dim_select, "\"$d\".\"$k\" AS \"${d}_${k}\"";
529
530                 for my $c ( keys %{$$p{output}{$d}} ) {
531                         push @dim_select, "\"$d\".\"$c\" AS \"${d}_${c}\"";
532                 }
533
534                 for my $c ( keys %{$$p{filter}{$d}} ) {
535                         next if (exists $$p{output}{$d}{$c});
536                         push @dim_select, "\"$d\".\"$c\" AS \"${d}_${c}\"";
537                 }
538         }
539
540         my $d_select =
541                 '(SELECT ' . join(',', @dim_select) .
542                 '  FROM ' . join(',', @dim_from) . ') AS dims';
543         
544         my @opord;
545         if (ref $$p{output_order}) {
546                 @opord = @{ $$p{output_order} };
547         } else {
548                 @opord = ( $$p{output_order} );
549         }
550         my @output_order = map { { (split ':')[1] => (split ':')[2] } } @opord;
551         
552         my $col = 1;
553         my @groupby;
554         my @output;
555         my @columns;
556         my @join;
557         my @join_base;
558         for my $pair (@output_order) {
559                 my ($t_name) = keys %$pair;
560                 my $t = $t_name;
561
562                 $t_name = "dims" if ($t ne $core);
563
564                 my $t_node = table_by_id($t);
565
566                 for my $c ( values %$pair ) {
567                         my $label = $t_node->findvalue("fields/field[\@name='$c']/label");
568
569                         my $full_col = $c;
570                         $full_col = "${t}_${c}" if ($t ne $t_name);
571                         $full_col = "\"$t_name\".\"$full_col\"";
572
573                         
574                         if (my $xform_type = $$p{xform}{type}{$t}{$c}) {
575                                 my $xform = $$OpenILS::WWW::Reporter::dtype_xforms{$xform_type};
576                                 if ($xform->{group}) {
577                                         push @groupby, $col;
578                                 }
579                                 $label = "$$xform{label} -- $label";
580
581                                 my $tmp = $xform->{'select'};
582                                 $tmp =~ s/\?COLNAME\?/$full_col/gs;
583                                 $tmp =~ s/\?PARAM\?/$$p{xform}{param}{$t}{$c}/gs;
584                                 $full_col = $tmp;
585                         } else {
586                                 push @groupby, $col;
587                         }
588
589                         push @output, "$full_col AS \"$label\"";
590                         push @columns, $label;
591                         $col++;
592                 }
593
594                 if ($t ne $t_name && (!@join_base || !grep{$t eq $_}@join_base)) {
595                         my $k = $doc->findvalue("//*[\@id='$t']/\@key");
596                         my $f = $doc->findvalue("//*[\@id='$t']/\@field");
597                         push @join, "dims.\"${t}_${k}\" = \"$core\".\"$f\"";
598                         push @join_base, $t;
599                 }
600         }
601
602         my @where;
603         my @bind;
604         for my $t ( keys %{$$p{filter}} ) {
605                 my $t_name = $t;
606                 $t_name = "dims" if ($t ne $core);
607
608                 my $t_node = table_by_id($t);
609
610                 for my $c ( keys %{$$p{filter}{$t}} ) {
611                         my $label = $t_node->findvalue("fields/field[\@name='$c']/label");
612
613                         my $full_col = $c;
614                         $full_col = "${t}_${c}" if ($t ne $t_name);
615                         $full_col = "\"$t_name\".\"$full_col\"";
616
617                         # XXX make this use widget specific code
618
619                         my ($fam) = keys %{ $$p{filter}{$t}{$c} };
620                         my ($w) = keys %{ $$p{filter}{$t}{$c}{$fam} };
621                         my $val = $$p{filter}{$t}{$c}{$fam}{$w};
622
623                         if (ref $val) {
624                                 push @where, "$full_col IN (".join(",",map {'?'}@$val).")";
625                                 push @bind, @$val;
626                         } else {
627                                 push @where, "$full_col = ?";
628                                 push @bind, $val;
629                         }
630                 }
631
632                 if ($t ne $t_name && (!@join_base || !grep{$t eq $_}@join_base)) {
633                         my $k = $doc->findvalue("//*[\@id='$t']/\@key");
634                         my $f = $doc->findvalue("//*[\@id='$t']/\@field");
635                         push @join, "dims.\"${t}_${k}\" = \"$core\".\"$f\"";
636                         push @join_base, $t;
637                 }
638         }
639
640         my $t = table_by_id($core)->findvalue('tablename');
641         my $from = " FROM $t AS \"$core\" RIGHT JOIN $d_select ON (". join(' AND ', @join).")";
642         my $select =
643                 "SELECT ".join(',', @output). $from;
644
645         $select .= ' WHERE '.join(' AND ', @where) if (@where);
646         $select .= ' GROUP BY '.join(',',@groupby) if (@groupby);
647
648         $r->{sql}->{'select'}   = $select;
649         $r->{sql}->{'bind'}     = \@bind;
650         $r->{sql}->{columns}    = \@columns;
651         $r->{sql}->{groupby}    = \@groupby;
652         
653 }
654
655
656
657
658
659