cgi/version.cgi

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5
   6 # Hack to work on merkel where suexec is in place
   7 BEGIN{
   8      if (defined $ENV{HTTP_HOST} and $ENV{HTTP_HOST} eq 'merkel.debian.org') {
   9           unshift @INC, qw(/home/don/perl/usr/share/perl5 /home/don/perl/usr/lib/perl5 /home/don/source);
  10           $ENV{DEBBUGS_CONFIG_FILE}="/home/don/config_internal";
  11      }
  12 }
  13
  14 # if we're running out of git, we want to use the git base directory as the
  15 # first INC directory. If you're not running out of git, don't do that.
  16 use File::Basename qw(dirname);
  17 use Cwd qw(abs_path);
  18 our $debbugs_dir;
  19 BEGIN {
  20     $debbugs_dir =
  21         abs_path(dirname(abs_path(__FILE__)) . '/../');
  22     # clear the taint; we'll assume that the absolute path to __FILE__ is the
  23     # right path if there's a .git directory there
  24     ($debbugs_dir) = $debbugs_dir =~ /([[:print:]]+)/;
  25     if (defined $debbugs_dir and
  26         -d $debbugs_dir . '/.git/') {
  27     } else {
  28         undef $debbugs_dir;
  29     }
  30     # if the first directory in @INC is not an absolute directory, assume that
  31     # someone has overridden us via -I.
  32     if ($INC[0] !~ /^\//) {
  33     }
  34 }
  35 use if defined $debbugs_dir, lib => $debbugs_dir;
  36
  37 use CGI::Simple;
  38
  39 # by default send this message nowhere
  40 # use CGI::Alert q(nobody@example.com);
  41
  42 use Debbugs::Config qw(:config);
  43
  44 our $VERSION=1;
  45 use Debbugs::DB;
  46 use Debbugs::CGI qw(htmlize_packagelinks html_escape cgi_parameters munge_url :cache);
  47 use Debbugs::Versions;
  48 use Debbugs::Versions::Dpkg;
  49 use Debbugs::Packages qw(get_versions make_source_versions);
  50 use HTML::Entities qw(encode_entities);
  51 use File::Temp qw(tempdir);
  52 use IO::File;
  53 use IO::Handle;
  54
  55 my @schema_arg = ();
  56 if (defined $config{database}) {
  57     my $s = Debbugs::DB->connect($config{database}) or
  58         die "Unable to connect to DB";
  59     @schema_arg = ('schema',$s);
  60 }
  61
  62 my %img_types = (svg => 'image/svg+xml',
  63                  png => 'image/png',
  64                 );
  65
  66 my $q = CGI::Simple->new();
  67
  68 my %cgi_var = cgi_parameters(query   => $q,
  69                              single  => [qw(package format ignore_boring width height collapse info)],
  70                              default => {package       => 'spamass-milter',
  71                                          found         => [],
  72                                          fixed         => [],
  73                                          ignore_boring => 1,
  74                                          collapse      => 0,
  75                                          format        => 'png',
  76                                          width         => undef,
  77                                          height        => undef,
  78                                          info          => 0,
  79                                         },
  80                             );
  81 my $this = munge_url('version.cgi?',
  82                      %cgi_var,
  83                     );
  84
  85 if (defined $cgi_var{width}) {
  86      $cgi_var{width} =~ /(\d+)/;
  87      $cgi_var{width} = $1;
  88 }
  89 if (defined $cgi_var{height}) {
  90      $cgi_var{height} =~ /(\d+)/;
  91      $cgi_var{height} = $1;
  92 }
  93
  94 if (defined $cgi_var{format}) {
  95      $cgi_var{format} =~ /(png|svg|jpg|gif)/;
  96      $cgi_var{format} = $1 || 'png';
  97 }
  98 else {
  99      $cgi_var{format} = 'png';
 100 }
 101
 102 my $etag;
 103 if ($cgi_var{info} and not defined $cgi_var{dot}) {
 104     $etag = etag_does_not_match(cgi=>$q,
 105                                 additional_data=>[grep {defined $_ ? $_ : ()}
 106                                                   @cgi_var{(qw(package ignore_boring),
 107                                                             qw(collapse))
 108                                                        },
 109                                                   $this,
 110                                                   $VERSION],
 111                                );
 112     if (not $etag) {
 113         print $q->header(-status => 304);
 114         print "304: Not modified\n";
 115         exit 0;
 116     }
 117     print $q->header(-status => 200,
 118                      -cache_control => 'public, max-age=86400',
 119                      -etag => $etag,
 120                      -content_type => 'text/html',
 121                     );
 122     print <<END;
 123 <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
 124 <html>
 125 END
 126      print '<head><title>'.html_escape($cgi_var{package}).' Version Graph</title></head>'."\n";
 127      print "<body>\n";
 128      print '<a href="'.html_escape(munge_url($this,ignore_boring=>$cgi_var{ignore_boring}?0:1)).
 129           '">['.($cgi_var{ignore_boring}?"Don't i":'I').'gnore boring]</a> ';
 130      print '<a href="'.html_escape(munge_url($this,collapse=>$cgi_var{collapse}?0:1)).
 131           '">['.($cgi_var{collapse}?"Don't c":'C').'ollapse]</a> ';
 132      print '<a href="'.html_escape(munge_url($this,dot=>1)).
 133           '">[Dot]</a><br>';
 134      print '<img src="'.html_escape(munge_url($this,info=>0)).'">';
 135      print <<END;
 136 </body>
 137 </html>
 138 END
 139           exit 0;
 140 }
 141
 142 # we want to first load the appropriate file,
 143 # then figure out which versions are there in which architectures,
 144 my %versions;
 145 my %version_to_dist;
 146 for my $dist (@{$config{distributions}}) {
 147      $versions{$dist} = [get_versions(package => [split /\s*,\s*/, $cgi_var{package}],
 148                                       dist => $dist,
 149                                       source => 1,
 150                                       @schema_arg,
 151                                      )];
 152      # make version_to_dist
 153      foreach my $version (@{$versions{$dist}}){
 154           push @{$version_to_dist{$version}}, $dist;
 155      }
 156 }
 157
 158 # then figure out which are affected.
 159 # turn found and fixed into full versions
 160 @{$cgi_var{found}} =
 161     map {make_source_versions(package => $_,
 162                               versions => $cgi_var{found})}
 163     split/\s*,\s*/, $cgi_var{package};
 164 @{$cgi_var{fixed}} =
 165     map {make_source_versions(package =>$_,
 166                               versions => $cgi_var{fixed})}
 167     split/\s*,\s*/, $cgi_var{package};
 168 my @interesting_versions =
 169     map {make_source_versions(package => $_,
 170                               versions => [keys %version_to_dist])}
 171     split/\s*,\s*/, $cgi_var{package};
 172
 173 # We need to be able to rip out leaves which the versions that do not affect the current versions of unstable/testing
 174 my %sources;
 175 @sources{map {m{(.+)/}; $1} @{$cgi_var{found}}} = (1) x @{$cgi_var{found}};
 176 @sources{map {m{(.+)/}; $1} @{$cgi_var{fixed}}} = (1) x @{$cgi_var{fixed}};
 177 @sources{map {m{(.+)/}; $1} @interesting_versions} = (1) x @interesting_versions;
 178
 179 # at this point, we know enough to calculate the etag.
 180
 181 my @versions_files;
 182 foreach my $source (sort keys %sources) {
 183     my $srchash = substr $source, 0, 1;
 184     next unless -e "$config{version_packages_dir}/$srchash/$source";
 185     push @versions_files, "$config{version_packages_dir}/$srchash/$source";
 186 }
 187
 188 $etag = etag_does_not_match(cgi=>$q,
 189                             additional_data=>[@cgi_var{(qw(package ignore_boring),
 190                                                         qw(collapse))
 191                                                    },
 192                                               $this,
 193                                               $VERSION],
 194                             files => [@versions_files
 195                                      ],
 196                            );
 197 if (not $etag) {
 198     print $q->header(-status => 304);
 199     print "304: Not modified\n";
 200     exit 0;
 201 }
 202
 203 my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
 204 for my $version_fn (@versions_files) {
 205     my $version_fh = IO::File->new($version_fn, 'r') or
 206         warn "Unable to open $version_fn for reading: $!";
 207     $version->load($version_fh);
 208 }
 209 # Here, we need to generate a short version to full version map
 210 my %version_map;
 211 foreach my $key (keys %{$version->{parent}}) {
 212      my ($short_version) = $key =~ m{/(.+)$};
 213      next unless length $short_version;
 214      # we let the first short version have presidence.
 215      $version_map{$short_version} = $key if not exists $version_map{$short_version};
 216 }
 217 # Turn all short versions into long versions
 218 for my $found_fixed (qw(found fixed)) {
 219      $cgi_var{$found_fixed} =
 220           [
 221            map {
 222                 if ($_ !~ m{/}) { # short version
 223                      ($version_map{$_});
 224                 }
 225                 else { # long version
 226                      ($_);
 227                 }
 228            } @{$cgi_var{$found_fixed}}
 229           ];
 230 }
 231 my %all_states = $version->allstates($cgi_var{found},$cgi_var{fixed});
 232
 233 my $dot = "digraph G {\n";
 234 if (defined $cgi_var{width} and defined $cgi_var{height}) {
 235      $dot .= qq(size="$cgi_var{width},$cgi_var{height}";\n);
 236 }
 237 my %state = (found  => ['fillcolor="salmon"',
 238                         'style="filled"',
 239                         'shape="ellipse"',
 240                        ],
 241              absent => ['fillcolor="grey"',
 242                         'style="filled"',
 243                         'shape="trapezium"',
 244                        ],
 245              fixed  => ['fillcolor="chartreuse"',
 246                         'style="filled"',
 247                         'shape="rect"',
 248                        ],
 249             );
 250 # TODO: Allow collapsing versions which are at the same state and not
 251 # in a suite.
 252 my %collapsed_nodes;
 253 my %group_nodes;
 254 if ($cgi_var{collapse}) {
 255      my %reversed_nodes;
 256      foreach my $key (keys %{$version->{parent}}) {
 257           next if $cgi_var{ignore_boring} and (not defined $all_states{$key}
 258                                                or $all_states{$key} eq 'absent');
 259           next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
 260           if (defined $version->{parent}{$key}) {
 261                next if $cgi_var{ignore_boring} and (not defined $all_states{$version->{parent}{$key}}
 262                                                     or $all_states{$version->{parent}{$key}} eq 'absent');
 263                next if $cgi_var{ignore_boring} and not version_relevant($version,$version->{parent}{$key},\@interesting_versions);
 264                push @{$reversed_nodes{$version->{parent}{$key}}},$key;
 265           }
 266           else {
 267                $reversed_nodes{$key} ||=[];
 268           }
 269      }
 270      # nodes that can be collapsed are those that have one child
 271      # are in the same state as their parent, and are not in a suite
 272      foreach my $key (keys %reversed_nodes) {
 273           if (not exists $version_to_dist{$key}
 274               and @{$reversed_nodes{$key}} <= 1
 275               and defined $version->{parent}{$key}
 276               and $all_states{$key} eq $all_states{$version->{parent}{$key}}
 277              ) {
 278                # check to see if there is an entry for the parent or child of this node
 279                my $group_node;
 280                if ((@{$reversed_nodes{$key}} and exists $collapsed_nodes{$reversed_nodes{$key}[0]})) {
 281                     $group_node = $collapsed_nodes{$reversed_nodes{$key}[0]};
 282                     if ($group_nodes{$group_node}{parent} eq $key) {
 283                          $group_nodes{$group_node}{parent} = $version->{parent}{$key};
 284                     }
 285                }
 286                if (defined $version->{parent}{$key} and exists $collapsed_nodes{$version->{parent}{$key}}) {
 287                     if (defined $group_node) {
 288                          #MWHAHAHAHAHA
 289                          my $collapser = $group_nodes{$collapsed_nodes{$version->{parent}{$key}}};
 290                          push @{$collapser->{collapsed_nodes}},@{$group_nodes{$group_node}{collapsed_nodes}},$group_node;
 291                          foreach (@{$collapser->{collapsed_nodes}}) {
 292                               if (exists $group_nodes{$_}) {
 293                                    $group_nodes{$_} = $collapser;
 294                               }
 295                          }
 296                     }
 297                     $group_node = $collapsed_nodes{$version->{parent}{$key}};
 298                }
 299                if (not defined $group_node) {
 300                     $group_node = "group_$key";
 301                     $group_nodes{$group_node} = {attr => qq("$group_node" [).join(',','label="some versions"',
 302                                                                                   @{$state{$all_states{$key}}},
 303                                                                                   'style="bold,filled"',
 304                                                                                  ).qq(]\n),
 305                                                  name => $group_node,
 306                                                  parent => $version->{parent}{$key},
 307                                                  collapsed_nodes => [],
 308                                                 };
 309                }
 310                $collapsed_nodes{$key} = $group_node;
 311           }
 312      }
 313      my %used_node;
 314      foreach my $group (values %group_nodes) {
 315           next if $used_node{$group->{name}};
 316           $used_node{$group->{name}} = 1;
 317           $dot .= $group->{attr};
 318      }
 319 }
 320
 321 foreach my $key (keys %all_states) {
 322      next if exists $collapsed_nodes{$key};
 323      next if $cgi_var{ignore_boring} and (not defined $all_states{$key}
 324                                           or $all_states{$key} eq 'absent');
 325      next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
 326      my @attributes = @{$state{$all_states{$key}}};
 327      if (exists $version_to_dist{$key}) {
 328           push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$key}}).")\"";
 329      }
 330      my $node_attributes = qq("$key" [).join(',',@attributes).qq(]\n);
 331      $dot .= $node_attributes;
 332 }
 333
 334 foreach my $key (keys %{$version->{parent}}) {
 335      next if not defined $version->{parent}{$key};
 336      next if $cgi_var{ignore_boring} and $all_states{$key} eq 'absent';
 337      next if $cgi_var{ignore_boring} and (not defined $all_states{$version->{parent}{$key}}
 338                                           or $all_states{$version->{parent}{$key}} eq 'absent');
 339      # Ignore branches which are not ancestors of a currently distributed version
 340      next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
 341      next if exists $collapsed_nodes{$key};
 342      $dot .= qq("$key").'->'.q(").
 343           (exists $collapsed_nodes{$version->{parent}{$key}}?
 344            $group_nodes{$collapsed_nodes{$version->{parent}{$key}}}{name}:$version->{parent}{$key}).
 345                 qq(" [dir="back"])."\n" if defined $version->{parent}{$key};
 346 }
 347 if ($cgi_var{collapse}) {
 348      my %used_node;
 349      foreach my $group (values %group_nodes) {
 350           next if $used_node{$group->{name}};
 351           next if not defined $group->{parent};
 352           $used_node{$group->{name}} = 1;
 353           $dot .= qq("$group->{name}").'->'.q(").
 354                (exists $collapsed_nodes{$group->{parent}}?
 355                 $group_nodes{$collapsed_nodes{$group->{parent}}}{name}:$group->{parent}).
 356                     qq(" [dir="back"])."\n";
 357      }
 358 }
 359 $dot .= "}\n";
 360
 361 my $temp_dir = tempdir(CLEANUP => 1);
 362
 363 if (not defined $cgi_var{dot}) {
 364      my $dot_fh = IO::File->new("$temp_dir/temp.dot",'w') or
 365           die "Unable to open $temp_dir/temp.dot for writing: $!";
 366      print {$dot_fh} $dot or die "Unable to print output to the dot file: $!";
 367      close $dot_fh or die "Unable to close the dot file: $!";
 368      system('dot','-T'.$cgi_var{format},"$temp_dir/temp.dot",'-o',"$temp_dir/temp.$cgi_var{format}") == 0
 369           or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?";
 370      my $img_fh = IO::File->new("$temp_dir/temp.$cgi_var{format}", 'r') or
 371           die "Unable to open $temp_dir/temp.$cgi_var{format} for reading: $!";
 372     print $q->header(-status => 200,
 373                      -cache_control => 'public, max-age=300',
 374                      -etag => $etag,
 375                      -content_type => $img_types{$cgi_var{format}},
 376                     );
 377      print <$img_fh>;
 378      close $img_fh;
 379 }
 380 else {
 381     print $q->header(-status => 200,
 382                      -cache_control => 'public, max-age=300',
 383                      -etag => $etag,
 384                      -content_type => 'text',
 385                     );
 386      print $dot;
 387 }
 388
 389
 390 our %_version_relevant_cache;
 391 sub version_relevant {
 392      my ($version,$test_version,$relevant_versions) = @_;
 393      for my $dist_version (@{$relevant_versions}) {
 394           if (exists $_version_relevant_cache{$dist_version}{$test_version}{$version}) {
 395                return 1 if $_version_relevant_cache{$dist_version}{$test_version}{$version};
 396           }
 397           else {
 398                my $rel = $version->isancestor($test_version,$dist_version);
 399                $_version_relevant_cache{$dist_version}{$test_version}{$version} = $rel;
 400                return 1 if $rel;
 401           }
 402      }
 403      return 0;
 404 }
 405
 406