Open-ILS/src/reporter/clark-kent.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use diagnostics;
   5 use DBI;
   6 use FileHandle;
   7 use XML::LibXML;
   8 use Getopt::Long;
   9 use DateTime;
  10 use DateTime::Format::ISO8601;
  11 use JSON;
  12 use Data::Dumper;
  13 use Text::CSV_XS;
  14 use Spreadsheet::WriteExcel::Big;
  15 use OpenSRF::EX qw/:try/;
  16 use OpenSRF::Utils qw/:daemon/;
  17 use OpenSRF::Utils::Logger qw/:level/;
  18 use OpenSRF::System;
  19 use OpenSRF::AppSession;
  20 use OpenSRF::Utils::SettingsClient;
  21 use OpenILS::Reporter::SQLBuilder;
  22 use POSIX;
  23 use GD::Graph::pie;
  24 use GD::Graph::bars3d;
  25 use GD::Graph::lines3d;
  26 use Tie::IxHash;
  27
  28 use open ':utf8';
  29
  30
  31 my ($count, $config, $lockfile, $daemon) = (1, '/openils/conf/bootstrap.conf', '/tmp/reporter-LOCK');
  32
  33 GetOptions(
  34         "daemon"        => \$daemon,
  35         "concurrency=i" => \$count,
  36         "boostrap=s"    => \$config,
  37         "lockfile=s"    => \$lockfile,
  38 );
  39
  40 if (-e $lockfile) {
  41         die "I seem to be running already. If not remove $lockfile, try again\n";
  42 }
  43
  44 open(F, ">$lockfile");
  45 print F $$;
  46 close F;
  47
  48 OpenSRF::System->bootstrap_client( config_file => $config );
  49
  50 # XXX Get this stuff from the settings server
  51 my $sc = OpenSRF::Utils::SettingsClient->new;
  52 my $db_driver = $sc->config_value( reporter => setup => database => 'driver' );
  53 my $db_host = $sc->config_value( reporter => setup => database => 'host' );
  54 my $db_port = $sc->config_value( reporter => setup => database => 'port' );
  55 my $db_name = $sc->config_value( reporter => setup => database => 'name' );
  56 my $db_user = $sc->config_value( reporter => setup => database => 'user' );
  57 my $db_pw = $sc->config_value( reporter => setup => database => 'password' );
  58
  59 my $output_base = $sc->config_value( reporter => setup => files => 'output_base' );
  60
  61 my $dsn = "dbi:" . $db_driver . ":dbname=" . $db_name .';host=' . $db_host . ';port=' . $db_port;
  62
  63 my ($dbh,$running,$sth,@reports,$run, $current_time);
  64
  65 daemonize("Clark Kent, waiting for trouble") if ($daemon);
  66
  67 DAEMON:
  68
  69 $dbh = DBI->connect($dsn,$db_user,$db_pw, {pg_enable_utf8 => 1, RaiseError => 1});
  70
  71 $current_time = DateTime->from_epoch( epoch => time() )->strftime('%FT%T%z');
  72
  73 # make sure we're not already running $count reports
  74 ($running) = $dbh->selectrow_array(<<SQL);
  75 SELECT  count(*)
  76   FROM  reporter.schedule
  77   WHERE start_time IS NOT NULL AND complete_time IS NULL;
  78 SQL
  79
  80 if ($count <= $running) {
  81         if ($daemon) {
  82                 $dbh->disconnect;
  83                 sleep 1;
  84                 POSIX::waitpid( -1, POSIX::WNOHANG );
  85                 sleep 60;
  86                 goto DAEMON;
  87         }
  88         print "Already running maximum ($running) concurrent reports\n";
  89         exit 1;
  90 }
  91
  92 # if we have some open slots then generate the sql
  93 $run = $count - $running;
  94
  95 $sth = $dbh->prepare(<<SQL);
  96 SELECT  *
  97   FROM  reporter.schedule
  98   WHERE start_time IS NULL AND run_time < NOW()
  99   ORDER BY run_time
 100   LIMIT $run;
 101 SQL
 102
 103 $sth->execute;
 104
 105 @reports = ();
 106 while (my $r = $sth->fetchrow_hashref) {
 107         my $s3 = $dbh->selectrow_hashref(<<"    SQL", {}, $r->{report});
 108                 SELECT * FROM reporter.report WHERE id = ?;
 109         SQL
 110
 111         my $s2 = $dbh->selectrow_hashref(<<"    SQL", {}, $s3->{template});
 112                 SELECT * FROM reporter.template WHERE id = ?;
 113         SQL
 114
 115         $s3->{template} = $s2;
 116         $r->{report} = $s3;
 117
 118         my $b = OpenILS::Reporter::SQLBuilder->new;
 119         $b->register_params( JSON->JSON2perl( $r->{report}->{data} ) );
 120
 121         $r->{resultset} = $b->parse_report( JSON->JSON2perl( $r->{report}->{template}->{data} ) );
 122         push @reports, $r;
 123 }
 124
 125 $sth->finish;
 126
 127 $dbh->disconnect;
 128
 129 # Now we spaun the report runners
 130
 131 for my $r ( @reports ) {
 132         next if (safe_fork());
 133
 134         # This is the child (runner) process;
 135         daemonize("Clark Kent reporting: $r->{report}->{name}");
 136
 137         $dbh = DBI->connect($dsn,$db_user,$db_pw, {pg_enable_utf8 => 1, RaiseError => 1});
 138
 139         try {
 140                 $dbh->do(<<'            SQL',{}, $r->{id});
 141                         UPDATE  reporter.schedule
 142                           SET   start_time = 'now',
 143                           WHERE id = ?;
 144                 SQL
 145
 146                 $sth = $dbh->prepare($r->{resultset}->toSQL);
 147
 148                 $sth->execute;
 149                 $r->{data} = $sth->fetchall_arrayref;
 150
 151                 $r->{column_labels} = [$r->{resultset}->column_label_list];
 152
 153                 if ($r->{resultset}->pivot_data && $r->{resultset}->pivot_label) {
 154                         my @labels = $r->{resultset}->column_label_list;
 155                         my $newdata = pivot_data(
 156                                 { columns => $r->{column_labels}, data => $r->{data}},
 157                                 $r->{resultset}->pivot_label,
 158                                 $r->{resultset}->pivot_data,
 159                                 $r->{resultset}->pivot_default
 160                         );
 161
 162                         $r->{column_labels} = $newdata->{columns};
 163                         $r->{data} = $newdata->{data};
 164                 }
 165
 166                 my $s2 = $r->{report}->{template}->{id};
 167                 my $s3 = $r->{report}->{id};
 168                 my $output = $r->{id};
 169
 170                 mkdir($output_base);
 171                 mkdir("$output_base/$s2");
 172                 mkdir("$output_base/$s2/$s3");
 173                 mkdir("$output_base/$s2/$s3/$output");
 174
 175                 my $output_dir = "$output_base/$s2/$s3/$output";
 176
 177                 if ( $r->{csv_format} eq 't') {
 178                         build_csv("$output_dir/report-data.csv", $r);
 179                 }
 180
 181                 if ( $r->{excel_format} eq 't') {
 182                         build_excel("$output_dir/report-data.xls", $r);
 183                 }
 184
 185                 if ( $r->{html_format} eq 't') {
 186                         mkdir("$output_dir/html");
 187                         build_html("$output_dir/report-data.html", $r);
 188                 }
 189
 190
 191                 $dbh->begin_work;
 192
 193                 if ($r->{report}->{recur} eq 't') {
 194                         my $sql = <<'                   SQL';
 195                                 INSERT INTO reporter.schedule ( report, folder, runner, run_time, email, csv_format, excel_format, html_format)
 196                                         VALUES ( ?, ?, ?, NOW() + ?, ?, ?, ?, ? );
 197                         SQL
 198
 199                         $dbh->do(
 200                                 $sql,
 201                                 {},
 202                                 $r->{report}->{id},
 203                                 $r->{folder},
 204                                 $r->{runner},
 205                                 $r->{report}->{recurance},
 206                                 $r->{email},
 207                                 $r->{csv_format},
 208                                 $r->{excel_format},
 209                                 $r->{html_format}
 210                         );
 211                 }
 212
 213                 $dbh->do(<<'            SQL',{}, $r->{id});
 214                         UPDATE  reporter.schedule
 215                           SET   complete_time = 'now'
 216                           WHERE id = ?;
 217                 SQL
 218
 219                 $dbh->commit;
 220
 221
 222         } otherwise {
 223                 my $e = shift;
 224                 $dbh->rollback;
 225                 $dbh->do(<<'            SQL',{}, $e, $r->{id});
 226                         UPDATE  reporter.schedule
 227                           SET   error_text = ?,
 228                                 complete_time = 'now',
 229                                 error_code = 1,
 230                           WHERE id = ?;
 231                 SQL
 232         };
 233
 234         $dbh->disconnect;
 235
 236         exit; # leave the child
 237 }
 238
 239 if ($daemon) {
 240         sleep 1;
 241         POSIX::waitpid( -1, POSIX::WNOHANG );
 242         sleep 60;
 243         goto DAEMON;
 244 }
 245
 246 #-------------------------------------------------------------------
 247
 248 sub build_csv {
 249         my $file = shift;
 250         my $r = shift;
 251
 252         my $csv = Text::CSV_XS->new({ always_quote => 1, eol => "\015\012" });
 253
 254         return unless ($csv);
 255
 256         my $f = new FileHandle (">$file");
 257
 258         $csv->print($f, $r->{column_labels});
 259         $csv->print($f, $_) for (@{$r->{data}});
 260
 261         $f->close;
 262 }
 263 sub build_excel {
 264         my $file = shift;
 265         my $r = shift;
 266         my $xls = Spreadsheet::WriteExcel::Big->new($file);
 267
 268         my $sheetname = substr($r->{report}->{name},1,31);
 269         $sheetname =~ s/\W/_/gos;
 270
 271         my $sheet = $xls->add_worksheet($sheetname);
 272
 273         $sheet->write_row('A1', $r->{column_labels});
 274
 275         $sheet->write_col('A2', $r->{data});
 276
 277         $xls->close;
 278 }
 279
 280 sub build_html {
 281         my $file = shift;
 282         my $r = shift;
 283
 284         my $index = new FileHandle (">$file");
 285         my $raw = new FileHandle (">$file.raw.html");
 286
 287         # index header
 288         print $index <<"        HEADER";
 289 <html>
 290         <head>
 291                 <title>$$r{report}{name}</title>
 292                 <style>
 293                         table { border-collapse: collapse; }
 294                         th { background-color: lightgray; }
 295                         td,th { border: solid black 1px; }
 296                         * { font-family: sans-serif; font-size: 10px; }
 297                 </style>
 298         </head>
 299         <body>
 300                 <h2><u>$$r{report}{name}</u></h2>
 301                 $$r{report}{description}<br/><br/><br/>
 302         HEADER
 303
 304
 305         # add a link to the raw output html
 306         print $index "<a href='report-data.html.raw.html'>Tabular Output</a><br/><br/><br/><br/>";
 307
 308         # create the raw output html file
 309         print $raw "<html><head><title>$$r{report}{name}</title>";
 310
 311         print $raw <<'  CSS';
 312                 <style>
 313                         table { border-collapse: collapse; }
 314                         th { background-color: lightgray; }
 315                         td,th { border: solid black 1px; }
 316                         * { font-family: sans-serif; font-size: 10px; }
 317                 </style>
 318         CSS
 319
 320         print $raw "</head><body><table>";
 321
 322         {       no warnings;
 323                 print $raw "<tr><th>".join('</th><th>',@{$r->{column_labels}}).'</th></tr>';
 324                 print $raw "<tr><td>".join('</td><td>',@$_                   ).'</td></tr>' for (@{$r->{data}});
 325         }
 326
 327         print $raw '</table></body></html>';
 328
 329         $raw->close;
 330
 331         # Time for a pie chart
 332         if ($r->{chart_pie} eq 't') {
 333                 my $pics = draw_pie($r, $file);
 334                 for my $pic (@$pics) {
 335                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
 336                 }
 337         }
 338
 339         print $index '<br/><br/><br/><br/>';
 340         # Time for a bar chart
 341         if ($r->{chart_bar} eq 't') {
 342                 my $pics = draw_bars($r, $file);
 343                 for my $pic (@$pics) {
 344                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
 345                 }
 346         }
 347
 348         print $index '<br/><br/><br/><br/>';
 349         # Time for a bar chart
 350         if ($r->{chart_line} eq 't') {
 351                 my $pics = draw_lines($r, $file);
 352                 for my $pic (@$pics) {
 353                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
 354                 }
 355         }
 356
 357         # and that's it!
 358         print $index '</body></html>';
 359
 360         $index->close;
 361 }
 362
 363 sub draw_pie {
 364         my $r = shift;
 365         my $file = shift;
 366
 367         my $data = $r->{data};
 368
 369         my @groups = $r->{resultset}->group_by_list(0);
 370
 371         my @values = (0 .. (scalar(@{$r->{column_labels}}) - 1));
 372         delete @values[@groups];
 373
 374         #my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
 375
 376         my @pics;
 377         for my $vcol (@values) {
 378                 next unless (defined $vcol);
 379
 380                 my @pic_data = ([],[]);
 381                 for my $row (@$data) {
 382                         next if (!defined($$row[$vcol]) || $$row[$vcol] == 0);
 383                         my $val = $$row[$vcol];
 384                         push @{$pic_data[0]}, join(" -- ", @$row[@groups])." ($val)";
 385                         push @{$pic_data[1]}, $val;
 386                 }
 387
 388                 next unless (@{$pic_data[0]});
 389
 390                 my $size = 300;
 391                 my $split = int(scalar(@{$pic_data[0]}) / $size);
 392                 my $last = scalar(@{$pic_data[0]}) % $size;
 393
 394                 for my $sub_graph (0 .. $split) {
 395
 396                         if ($sub_graph == $split) {
 397                                 $size = $last;
 398                         }
 399
 400                         my @sub_data;
 401                         for my $set (@pic_data) {
 402                                 push @sub_data, [ splice(@$set,0,$size) ];
 403                         }
 404
 405                         my $pic = new GD::Graph::pie;
 406
 407                         $pic->set(
 408                                 label                   => $r->{column_labels}->[$vcol],
 409                                 start_angle             => 180,
 410                                 legend_placement        => 'R',
 411                                 #logo                   => $logo,
 412                                 #logo_position          => 'TL',
 413                                 #logo_resize            => 0.5,
 414                                 show_values             => 1,
 415                         );
 416
 417                         my $format = $pic->export_format;
 418
 419                         open(IMG, ">$file.pie.$vcol.$sub_graph.$format");
 420                         binmode IMG;
 421
 422                         my $forgetit = 0;
 423                         try {
 424                                 $pic->plot(\@sub_data) or die $pic->error;
 425                                 print IMG $pic->gd->$format;
 426                         } otherwise {
 427                                 my $e = shift;
 428                                 warn "Couldn't draw $file.pie.$vcol.$sub_graph.$format : $e";
 429                                 $forgetit = 1;
 430                         };
 431
 432                         close IMG;
 433
 434
 435                         push @pics,
 436                                 { file => "pie.$vcol.$sub_graph.$format",
 437                                   name => $r->{column_labels}->[$vcol].' (Pie)',
 438                                 } unless ($forgetit);
 439
 440                         last if ($sub_graph == $split);
 441                 }
 442
 443         }
 444
 445         return \@pics;
 446 }
 447
 448 sub draw_bars {
 449         my $r = shift;
 450         my $file = shift;
 451         my $data = $r->{data};
 452
 453         #my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
 454
 455         my @groups = $r->{resultset}->group_by_list(0);
 456
 457
 458         my @values = (0 .. (scalar(@{$r->{column_labels}}) - 1));
 459         splice(@values,$_,1) for (reverse @groups);
 460
 461         my @pic_data;
 462         {       no warnings;
 463                 for my $row (@$data) {
 464                         push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
 465                 }
 466         }
 467
 468         my @leg;
 469         my $set = 1;
 470
 471         my %trim_candidates;
 472
 473         my $max_y = 0;
 474         for my $vcol (@values) {
 475                 next unless (defined $vcol);
 476
 477
 478                 my $pos = 0;
 479                 for my $row (@$data) {
 480                         my $val = $$row[$vcol] ? $$row[$vcol] : 0;
 481                         push @{$pic_data[$set]}, $val;
 482                         $max_y = $val if ($val > $max_y);
 483                         $trim_candidates{$pos}++ if ($val == 0);
 484                         $pos++;
 485                 }
 486
 487                 $set++;
 488         }
 489         my $set_count = scalar(@pic_data) - 1;
 490         my @trim_cols = grep { $trim_candidates{$_} == $set_count } keys %trim_candidates;
 491
 492         my @new_data;
 493         my @use_me;
 494         my @no_use;
 495         my $set_index = 0;
 496         for my $dataset (@pic_data) {
 497                 splice(@$dataset,$_,1) for (sort { $b <=> $a } @trim_cols);
 498
 499                 if (grep { $_ } @$dataset) {
 500                         push @new_data, $dataset;
 501                         push @use_me, $set_index;
 502                 } else {
 503                         push @no_use, $set_index;
 504                 }
 505                 $set_index++;
 506
 507         }
 508
 509         return [] unless ($new_data[0] && @{$new_data[0]});
 510
 511         for my $col (@use_me) {
 512                 push @leg, $r->{column_labels}->[$col + @groups - 1] if (map { 1 } grep { $col == $_ } @values);
 513         }
 514
 515         my $w = 100 + 10 * scalar(@{$new_data[0]});
 516         $w = 400 if ($w < 400);
 517
 518         my $h = 10 * (scalar(@new_data) / 2);
 519
 520         $h = 0 if ($h < 0);
 521
 522         my $pic = new GD::Graph::bars3d ($w + 250, $h + 500);
 523
 524         $pic->set(
 525                 title                   => $r->{report}{name},
 526                 x_labels_vertical       => 1,
 527                 shading                 => 1,
 528                 bar_depth               => 5,
 529                 bar_spacing             => 2,
 530                 y_max_value             => $max_y,
 531                 legend_placement        => 'TR',
 532                 boxclr                  => 'lgray',
 533                 #logo                   => $logo,
 534                 #logo_position          => 'R',
 535                 #logo_resize            => 0.5,
 536                 show_values             => 1,
 537                 overwrite               => 1,
 538         );
 539         $pic->set_legend(@leg);
 540
 541         my $format = $pic->export_format;
 542
 543         open(IMG, ">$file.bar.$format");
 544         binmode IMG;
 545
 546         try {
 547                 $pic->plot(\@new_data) or die $pic->error;
 548                 print IMG $pic->gd->$format;
 549         } otherwise {
 550                 my $e = shift;
 551                 warn "Couldn't draw $file.bar.$format : $e";
 552         };
 553
 554         close IMG;
 555
 556         return [{ file => "bar.$format",
 557                   name => $r->{report}{name}.' (Bar)',
 558                 }];
 559
 560 }
 561
 562 sub draw_lines {
 563         my $r = shift;
 564         my $file = shift;
 565         my $data = $r->{data};
 566
 567         #my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
 568
 569         my @groups = $r->{resultset}->group_by_list(0);
 570
 571         my @values = (0 .. (scalar(@{$r->{column_labels}}) - 1));
 572         splice(@values,$_,1) for (reverse @groups);
 573
 574         my @pic_data;
 575         {       no warnings;
 576                 for my $row (@$data) {
 577                         push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
 578                 }
 579         }
 580
 581         my @leg;
 582         my $set = 1;
 583
 584         my $max_y = 0;
 585         for my $vcol (@values) {
 586                 next unless (defined $vcol);
 587
 588
 589                 for my $row (@$data) {
 590                         my $val = $$row[$vcol] ? $$row[$vcol] : 0;
 591                         push @{$pic_data[$set]}, $val;
 592                         $max_y = $val if ($val > $max_y);
 593                 }
 594
 595                 $set++;
 596         }
 597         my $set_count = scalar(@pic_data) - 1;
 598
 599         my @new_data;
 600         my @use_me;
 601         my @no_use;
 602         my $set_index = 0;
 603         for my $dataset (@pic_data) {
 604
 605                 if (grep { $_ } @$dataset) {
 606                         push @new_data, $dataset;
 607                         push @use_me, $set_index;
 608                 } else {
 609                         push @no_use, $set_index;
 610                 }
 611                 $set_index++;
 612
 613         }
 614
 615         for my $col (@use_me) {
 616                 push @leg, $r->{column_labels}->[$col + @groups - 1] if (map { 1 } grep { $col == $_ } @values);
 617         }
 618
 619         my $w = 100 + 10 * scalar(@{$new_data[0]});
 620         $w = 400 if ($w < 400);
 621
 622         my $h = 10 * (scalar(@new_data) / 2);
 623
 624         $h = 0 if ($h < 0);
 625
 626         my $pic = new GD::Graph::lines3d ($w + 250, $h + 500);
 627
 628         $pic->set(
 629                 title                   => $r->{report}{name},
 630                 x_labels_vertical       => 1,
 631                 shading                 => 1,
 632                 line_depth              => 5,
 633                 y_max_value             => $max_y,
 634                 legend_placement        => 'TR',
 635                 boxclr                  => 'lgray',
 636                 #logo                   => $logo,
 637                 #logo_position          => 'R',
 638                 #logo_resize            => 0.5,
 639                 show_values             => 1,
 640                 overwrite               => 1,
 641         );
 642         $pic->set_legend(@leg);
 643
 644         my $format = $pic->export_format;
 645
 646         open(IMG, ">$file.line.$format");
 647         binmode IMG;
 648
 649         try {
 650                 $pic->plot(\@new_data) or die $pic->error;
 651                 print IMG $pic->gd->$format;
 652         } otherwise {
 653                 my $e = shift;
 654                 warn "Couldn't draw $file.line.$format : $e";
 655         };
 656
 657         close IMG;
 658
 659         return [{ file => "line.$format",
 660                   name => $r->{report}{name}.' (Bar)',
 661                 }];
 662
 663 }
 664
 665
 666 sub pivot_data {
 667         my $blob = shift;
 668         my $pivot_label = shift;
 669         my $pivot_data = shift;
 670         my $default = shift;
 671         $default = 0 unless (defined $default);
 672
 673         my $data = $$blob{data};
 674         my $cols = $$blob{columns};
 675
 676         my @keep_labels =  @$cols;
 677         splice(@keep_labels, $_ - 1, 1) for (reverse sort ($pivot_label, $pivot_data));
 678
 679         my @keep_cols = (0 .. @$cols - 1);
 680         splice(@keep_cols, $_ - 1, 1) for (reverse sort ($pivot_label, $pivot_data));
 681
 682         #first, find the unique list of pivot values
 683         my %tmp;
 684         for my $row (@$data) {
 685                 $tmp{ $$row[$pivot_label - 1] } = 1;
 686         }
 687         my @new_cols = sort keys %tmp;
 688
 689         tie my %split_data, 'Tie::IxHash';
 690         for my $row (@$data) {
 691
 692                 my $row_fp = ''. join('', map { defined($$row[$_]) ? $$row[$_] : '' } @keep_cols);
 693                 $split_data{$row_fp} ||= [];
 694
 695                 push @{ $split_data{$row_fp} }, $row;
 696         }
 697
 698
 699         #now loop over the data, building a new result set
 700         tie my %new_data, 'Tie::IxHash';
 701
 702         for my $fp ( keys %split_data ) {
 703
 704                 $new_data{$fp} = [];
 705
 706                 for my $col (@keep_cols) {
 707                         push @{ $new_data{$fp} }, $split_data{$fp}[0][$col];
 708                 }
 709
 710                 for my $col (@new_cols) {
 711
 712                         my ($datum) = map { $_->[$pivot_data - 1] } grep { $_->[$pivot_label - 1] eq $col } @{ $split_data{$fp} };
 713                         $datum ||= $default;
 714                         push @{ $new_data{$fp} }, $datum;
 715                 }
 716         }
 717
 718         push @keep_labels, @new_cols;
 719
 720         return { columns => \@keep_labels, data => [ values %new_data ] };
 721 }
 722
 723