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