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