add initial code for updating bug status cache

diff --git a/Debbugs/DB/ResultSet/BugStatusCache.pm b/Debbugs/DB/ResultSet/BugStatusCache.pm
new file mode 100644 (file)
index 0000000..264e0a9
--- /dev/null
+++ b/Debbugs/DB/ResultSet/BugStatusCache.pm
@@ -0,0 +1,73 @@
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later version. See the
+# file README and COPYING for more information.
+# Copyright 2017 by Don Armstrong <don@donarmstrong.com>.
+use utf8;
+package Debbugs::DB::ResultSet::BugStatusCache;
+
+=head1 NAME
+
+Debbugs::DB::ResultSet::BugStatusCache - Bug result set operations
+
+=head1 SYNOPSIS
+
+
+
+=head1 DESCRIPTION
+
+
+
+=cut
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::ResultSet';
+__PACKAGE__->load_components('Helper::ResultSet');
+
+use Debbugs::DB::Util qw(select_one);
+
+use List::MoreUtils qw(natatime);
+
+
+=over
+
+=item update_bug_status
+
+       $s->resultset('BugStatusCache')->
+           update_bug_status($bug->id,
+                             $suite->{id},
+                             undef,
+                             $presence,
+                             );
+
+Update the status information for a particular bug at a particular suite
+
+=cut
+
+sub update_bug_status {
+    my ($self,@args) = @_;
+    return $self->result_source->schema->storage->
+       dbh_do(sub {
+                  my ($s,$dbh,$bug,$suite,$arch,$status,$modified,$asof) = @_;
+                  select_one($dbh,<<'SQL',$bug,$suite,$arch,$status,$status);
+INSERT INTO bug_status_cache (bug,suite,arch,status,modified,asof)
+VALUES (?,?,?,?,NOW(),NOW())
+ON CONFLICT (bug,suite,arch) DO 
+UPDATE SET asof=NOW(),modified=CASE WHEN status=? THEN modified ELSE NOW() END
+RETURNING status;
+SQL
+              },
+           @args
+             );
+}
+
+
+=back
+
+=cut
+
+
+1;
+
+__END__

diff --git a/bin/debbugs-updatesqlcache b/bin/debbugs-updatesqlcache
new file mode 100644 (file)
index 0000000..85ae5c7
--- /dev/null
+++ b/bin/debbugs-updatesqlcache
@@ -0,0 +1,325 @@
+#! /usr/bin/perl
+# debbugs-updatesqlcache is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later version, at your
+# option. See the file README and COPYING for more information.
+# Copyright 2016 by Don Armstrong <don@donarmstrong.com>.
+
+
+use warnings;
+use strict;
+
+use Getopt::Long qw(:config no_ignore_case);
+use Pod::Usage;
+
+=head1 NAME
+
+debbugs-updatesqlcache -- Update Debbugs SQL Cache
+
+=head1 SYNOPSIS
+
+debbugs-updatesqlcache [options]
+
+ Options:
+  --quick, -q only load changed bugs
+  --progress Show progress bar
+  --service, -s service name
+  --sysconfdir, -c postgresql service config dir
+  --spool-dir debbugs spool directory
+  --debug, -d debugging level (Default 0)
+  --help, -h display this help
+  --man, -m display manual
+
+=head1 SUBCOMMANDS
+
+=head2 help
+
+Display this manual
+
+=head2 update
+
+Update SQL cache
+
+=head1 OPTIONS
+
+=over
+
+=item B<--quick, -q>
+
+Only update things which may have changed
+
+=item B<--progress>
+
+Show progress bar (requires Term::ProgressBar)
+
+=item B<--service,-s>
+
+Postgreql service to use; defaults to debbugs
+
+=item B<--sysconfdir,-c>
+
+System configuration directory to use; if not set, defaults to the
+postgresql default. [Operates by setting PGSYSCONFDIR]
+
+=item B<--spool-dir>
+
+Debbugs spool directory; defaults to the value configured in the
+debbugs configuration file.
+
+=item B<--verbose>
+
+Output more information about what is happening. Probably not useful
+if you also set --progress.
+
+=item B<--debug, -d>
+
+Debug verbosity.
+
+=item B<--help, -h>
+
+Display brief useage information.
+
+=item B<--man, -m>
+
+Display this manual.
+
+=back
+
+
+=cut
+
+
+use vars qw($DEBUG);
+
+use Debbugs::Common qw(checkpid lockpid get_hashname getparsedaddrs getbugcomponent make_list getsourcemaintainers);
+use Debbugs::Config qw(:config);
+use Debbugs::Status qw(bug_presence);
+use Debbugs::DB;
+use DateTime;
+use File::stat;
+
+
+my %options =
+    (debug           => 0,
+     help            => 0,
+     man             => 0,
+     verbose         => 0,
+     quiet           => 0,
+     quick           => 0,
+     service         => $config{debbugs_db},
+     progress        => 0,
+    );
+
+Getopt::Long::Configure('pass_through');
+GetOptions(\%options,
+           'quick|q',
+           'service|s=s',
+           'sysconfdir|c=s',
+           'progress!',
+           'spool_dir|spool-dir=s',
+           'verbose|v+',
+           'quiet+',
+           'debug|d+','help|h|?','man|m');
+Getopt::Long::Configure('default');
+
+pod2usage() if $options{help};
+pod2usage({verbose=>2}) if $options{man};
+
+$DEBUG = $options{debug};
+
+my %subcommands =
+    ('update' => {function => \&update_cache,
+               },
+     'help' => {function => sub {pod2usage({verbose => 2});}}
+    );
+
+my @USAGE_ERRORS;
+$options{verbose} = $options{verbose} - $options{quiet};
+
+if ($options{progress}) {
+    eval "use Term::ProgressBar";
+    push @USAGE_ERRORS, "You asked for a progress bar, but Term::ProgressBar isn't installed" if $@;
+}
+
+
+pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
+
+if (exists $options{sysconfdir}) {
+    if (not defined $options{sysconfdir} or not length $options{sysconfdir}) {
+        delete $ENV{PGSYSCONFDIR};
+    } else {
+        $ENV{PGSYSCONFDIR} = $options{sysconfdir};
+    }
+}
+
+if (exists $options{spool_dir} and defined $options{spool_dir}) {
+    $config{spool_dir} = $options{spool_dir};
+}
+
+my $prog_bar;
+if ($options{progress}) {
+    $prog_bar = eval "Term::ProgressBar->new({count => 1,ETA=>q(linear)})";
+    warn "Unable to initialize progress bar: $@" if not $prog_bar;
+}
+
+
+my ($subcommand) = shift @ARGV;
+if (not defined $subcommand) {
+    $subcommand = 'help';
+    print STDERR "You must provide a subcommand; displaying usage.\n";
+    pod2usage();
+} elsif (not exists $subcommands{$subcommand}) {
+    print STDERR "$subcommand is not a valid subcommand; displaying usage.\n";
+    pod2usage();
+}
+
+my $opts =
+    handle_subcommand_arguments(\@ARGV,$subcommands{$subcommand}{arguments});
+$subcommands{$subcommand}{function}->(\%options,$opts,$prog_bar,\%config,\@ARGV);
+
+sub update_cache {
+    my ($options,$opts,$p,$config,$argv) = @_;
+
+    my $verbose = $options->{debug};
+    # select bugs to update
+
+    # basically, if this is a quick run, we want any bug which has
+    # been modified or any bug which belongs to a package which has a
+    # new version; otherwise, walk every bug
+    my $s = db_connect($options);
+
+    # get all of the possible architectures that we might care about
+    # select distinct s.codename,a.arch from bin_associations ba join bin_ver bv on ba.bin=bv.id join suite s on ba.suite=s.id join arch a on bv.arch=a.id;
+
+    my @suites =
+       $s->resultset('Suite')->
+       search_rs({active => 1,
+                 },
+                {result_class => 'DBIx::Class::ResultClass::HashRefInflator'}
+                )->all();
+    my $bugs;
+    if ($opts->{quick}) {
+        # select last status update
+
+       # select bugs which have been modified since the last updatex
+    } else {
+        $bugs = $s->resultset('Bug')->
+           search_rs(undef,
+                    {rows => 100});
+    }
+    my $update_bug =
+       sub {
+           my @bugs = @_;
+           for my $bug (@bugs) {
+               my $status = read_bug(bug => $bug->id);
+               for my $suite (@suites) {
+                   my $presence =
+                       bug_presence(bug => $bug->id,
+                                    status => $status,
+                                    dist => $suite->{suite_name},
+                                   );
+                   $s->resultset('BugStatusCache')->
+                       update_bug_status($bug->id,
+                                         $suite->{id},
+                                         undef,
+                                         $presence,
+                                        );
+               }
+           }
+       };
+    my $last_page = 1;
+    if ($bugs->is_paged) {
+       $last_page = 
+           $bugs->pager->last_page;
+    }
+    $p->target($last_page) if defined $p;
+    for my $page (1..$last_page) {
+       my $bugs_on_page = $bugs;
+       if ($bugs->is_paged) {
+           $bugs_on_page = $bugs->page($page);
+       }
+       $s->txn_do($update_bug,
+                  $bugs_on_page->all());
+    }
+}
+
+
+sub handle_subcommand_arguments {
+    my ($argv,$args) = @_;
+    my $subopt = {};
+    Getopt::Long::GetOptionsFromArray($argv,
+                              $subopt,
+                              keys %{$args},
+                             );
+    my @usage_errors;
+    for my $arg  (keys %{$args}) {
+        next unless $args->{$arg};
+        my $r_arg = $arg; # real argument name
+        $r_arg =~ s/[=\|].+//g;
+        if (not defined $subopt->{$r_arg}) {
+            push @usage_errors, "You must give a $r_arg option";
+        }
+    }
+    pod2usage(join("\n",@usage_errors)) if @usage_errors;
+    return $subopt;
+}
+
+sub get_lock{
+    my ($subcommand,$config,$options) = @_;
+    if (not lockpid($config->{spool_dir}.'/lock/debbugs-updatesqlcache-$subcommand')) {
+        if ($options->{quick}) {
+            # If this is a quick run, just exit
+            print STDERR "Another debbugs-updatesqlcache is running; stopping\n" if $options->{verbose};
+            exit 0;
+        }
+        print STDERR "Another debbugs-updatesqlcache is running; stopping\n";
+        exit 1;
+    }
+}
+
+sub db_connect {
+    my ($options) = @_;
+    # connect to the database; figure out how to handle errors
+    # properly here.
+    my $s = Debbugs::DB->connect('dbi:Pg:service='.$options->{service}) or
+        die "Unable to connect to database: ";
+}
+
+sub walk_bugs {
+    my ($dirs,$p,$what,$verbose,$sub) = @_;
+    my @dirs = @{$dirs};
+    my $tot_dirs = @dirs;
+    my $done_dirs = 0;
+    my $avg_subfiles = 0;
+    my $completed_files = 0;
+    while (my $dir = shift @dirs) {
+        printf "Doing dir %s ...\n", $dir if $verbose;
+
+        opendir(DIR, "$dir/.") or die "opendir $dir: $!";
+        my @subdirs = readdir(DIR);
+        closedir(DIR);
+
+        my @list = map { m/^(\d+)\.$what$/?($1):() } @subdirs;
+        $tot_dirs -= @dirs;
+        push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs;
+        $tot_dirs += @dirs;
+        if ($avg_subfiles == 0) {
+            $avg_subfiles = @list;
+        }
+
+        $p->target($avg_subfiles*($tot_dirs-$done_dirs)+$completed_files+@list) if $p;
+        $avg_subfiles = ($avg_subfiles * $done_dirs + @list) / ($done_dirs+1);
+        $done_dirs += 1;
+
+        for my $bug (@list) {
+            $completed_files++;
+            $p->update($completed_files) if $p;
+            print "Up to $completed_files bugs...\n" if ($completed_files % 100 == 0 && $verbose);
+            $sub->($bug);
+        }
+    }
+    $p->remove() if $p;
+}
+
+
+
+__END__