tools/cgi/darcs.cgi.in

   1 #!/usr/bin/perl -T
   2 #
   3 # darcs.cgi - the darcs repository viewer
   4 #
   5 # Copyright (c) 2004 Will Glozer
   6 #
   7 # Permission is hereby granted, free of charge, to any person obtaining
   8 # a copy of this software and associated documentation files (the
   9 # "Software"), to deal in the Software without restriction, including
  10 # without limitation the rights to use, copy, modify, merge, publish,
  11 # distribute, sublicense, and/or sell copies of the Software, and to
  12 # permit persons to whom the Software is furnished to do so, subject to
  13 # the following conditions
  14 #
  15 # The above copyright notice and this permission notice shall be
  16 # included in all copies or substantial portions of the Software.
  17 #
  18 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 # NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
  22 # LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
  23 # OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
  24 # WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  25
  26 #
  27 # This program calls darcs (or its own subroutines) to generate XML
  28 # which is rendered into HTML by XSLT.  It is capable of displaying
  29 # the files in a repository, various patch histories, annotations, etc.
  30 #
  31
  32 use strict;
  33
  34 use CGI qw( :standard );
  35 use CGI::Util;
  36 use File::Basename;
  37 use File::stat;
  38 use IO::File;
  39 use POSIX;
  40
  41 ## the following variables can be customized to reflect your system
  42 ## configuration by defining them appropriately in the file
  43 ## "@sysconfdir@/darcs/cgi.conf".  The syntax accepts equals signs or simply
  44 ## blanks separating values from assignments.
  45
  46 $ENV{'PATH'} = read_conf('PATH', $ENV{'PATH'});
  47
  48 # path to executables, or just the executable if they are in $ENV{'PATH'}
  49 my $darcs_program    = read_conf("darcs", "darcs");
  50 my $xslt_program     = read_conf("xsltproc", "xsltproc");
  51
  52 # directory containing repositories
  53 my $repository_root  = read_conf("reposdir", "/var/www");
  54
  55 # XSLT template locations
  56 my $template_root = read_conf("xslt_dir", '@datadir@/darcs/xslt');
  57
  58 my $xslt_annotate = "$template_root/annotate.xslt";
  59 my $xslt_browse   = "$template_root/browse.xslt";
  60 my $xslt_patches  = "$template_root/patches.xslt";
  61 my $xslt_repos    = "$template_root/repos.xslt";
  62 my $xslt_rss      = "$template_root/rss.xslt";
  63
  64 my $xslt_errors   = "$template_root/errors.xslt";
  65
  66 # CSS stylesheet that XSLT templates refer to.  This is a HTTP request
  67 # path, not a local file system path. The default will cause darcs.cgi
  68 # to serve the stylesheet rather than the web server.
  69 my $stylesheet = read_conf("stylesheet", "/cgi-bin/darcs.cgi/styles.css");
  70
  71 # location of the CSS stylesheet that darcs.cgi will serve if it
  72 # receives a request for '/styles.css'
  73 my $css_styles = read_conf("css_styles", '@sysconfdir@/darcs/styles.css');
  74
  75 # location of the favicon that darcs.cgi will serve if it
  76 # receives a request for '/[\w\-]+/favicon.ico'
  77 my $favicon = read_conf("favicon", "/cgi-bin/favicon.ico");
  78
  79 # XML source for the error pages
  80 my $xml_errors = "$template_root/errors.xml";
  81
  82 # encoding to include in XML declaration
  83 my $xml_encoding = read_conf("xml_encoding", "UTF-8");
  84
  85 ## end customization
  86
  87 # ----------------------------------------------------------------------
  88
  89 # read a value from the cgi.conf file.
  90 {
  91   my(%conf);
  92
  93   sub read_conf {
  94     my ($flag, $val) = @_;
  95     $val = "" if !defined($val);
  96
  97     if (!%conf && open(CGI_CONF, '@sysconfdir@/darcs/cgi.conf')) {
  98       while (<CGI_CONF>) {
  99         chomp;
 100         next if /^\s*(?:\#.*)?$/;   # Skip blank lines and comment lines
 101         if (/^\s*(\S+)\s*(?:\=\s*)?(\S+)\s*$/) {
 102            $conf{$1} = $2;
 103            # print "read_conf: $1 = $2\n";
 104         } else {
 105            warn "read_conf: $_\n";
 106         }
 107       }
 108       close(CGI_CONF);
 109     }
 110
 111     $val = $conf{$flag} if exists($conf{$flag});
 112
 113     return $val;
 114   }
 115 }
 116
 117 # open xsltproc to transform and output `xml' with stylesheet file `xslt'
 118 sub transform {
 119     my ($xslt, $args, $content_type) = @_;
 120
 121     $| = 1;
 122     printf "Content-type: %s\r\n\r\n", $content_type || "text/html";
 123     my $pipe = new IO::File "| $xslt_program $args $xslt -";
 124     $pipe->autoflush(0);
 125     return $pipe;
 126 }
 127
 128 sub pristine_dir {
 129     my ($repo) = @_;
 130     my $pristine = "current";
 131     if (! -d "${repository_root}/${repo}/_darcs/$pristine") {
 132         $pristine = "pristine";
 133     }
 134     return "${repository_root}/${repo}/_darcs/$pristine";
 135 }
 136
 137 # begin an XML document with a root element and the repository path
 138 sub make_xml {
 139     my ($fh, $repo, $dir, $file) = @_;
 140     my ($full_path, $path) = '/';
 141
 142     printf $fh qq(<?xml version="1.0" encoding="$xml_encoding"?>\n);
 143
 144     printf $fh qq(<darcs repository="$repo" target="%s/%s%s">\n),
 145         $repo, ($dir ? "$dir/" : ''), ($file ? "$file" : '');
 146
 147     print $fh qq(<path>\n);
 148     foreach $path (split('/', "$repo/$dir")) {
 149         $full_path .= "$path/";
 150         print $fh qq(<directory full-path="$full_path">$path</directory>\n);
 151     }
 152     if ($file) {
 153         print $fh qq(<file full-path="$full_path$file">$file</file>\n) if $file;
 154     }
 155     print $fh qq(</path>\n\n);
 156 }
 157
 158 # finish XML output
 159 sub finish_xml {
 160     my ($fh) = @_;
 161     print $fh "\n</darcs>\n";
 162     $fh->flush;
 163 }
 164
 165 # run darcs and wrap the output in an XML document
 166 sub darcs_xml {
 167     my ($fh, $repo, $cmd, $args, $dir, $file) = @_;
 168
 169     make_xml($fh, $repo, $dir, $file);
 170
 171     push(@$args, '--xml-output');
 172     darcs($fh, $repo, $cmd, $args, $dir, $file);
 173
 174     finish_xml($fh);
 175 }
 176
 177 # run darcs with output redirected to the specified file handle
 178 sub darcs {
 179     my ($fh, $repo, $cmd, $args, $dir, $file) = @_;
 180     my (@darcs_argv) = ($darcs_program, $cmd, @$args);
 181
 182     # push target only if there is one, otherwise darcs will get an empty param
 183     if ($dir || $file) {
 184         push(@darcs_argv, sprintf("%s%s%s", $dir, ($dir ? '/' : ''), $file));
 185     }
 186
 187     my($pid) = fork;
 188     if ($pid) {
 189         # in the parent process
 190         my($status) = waitpid($pid, 0);
 191         die "$darcs_program exited with status $?\n" if $?;
 192     } elsif(defined($pid)) {
 193         # in the child process
 194         open(STDIN, '/dev/null');
 195         if (defined($fh)) {
 196             open(STDOUT, '>&', $fh)
 197                 || die "can't dup to stdout: $!\n";
 198         }
 199         chdir "$repository_root/$repo"
 200             || die "chdir: $repository_root/$repo: $!\n";
 201         exec @darcs_argv;
 202         die "can't exec ".$darcs_argv[0].": $!\n";
 203     } else {
 204         # fork failed
 205         die "can't fork: $!\n";
 206     }
 207 }
 208
 209 # get a directory listing as XML output
 210 sub dir_listing {
 211     my ($fh, $repo, $dir) = @_;
 212     make_xml($fh, $repo, $dir, '');
 213
 214     print $fh "<files>\n";
 215     my $dir_ = pristine_dir ($repo) . "/$dir";
 216     opendir(DH, $dir_);
 217     while( defined (my $file_ = readdir(DH)) ) {
 218         next if $file_ =~ /^\.\.?$/;
 219         my $file = "$dir_/$file_";
 220         my $secs  = stat($file)->mtime;
 221         my $mtime = localtime($secs);
 222         my $ts = POSIX::strftime("%Y%m%d%H%M%S", gmtime $secs);
 223
 224         my ($name, $type);
 225
 226          if (-d $file) {
 227              ($name, $type) = (basename($file) . '/', 'directory');
 228          } else {
 229              ($name, $type) = (basename($file), 'file');
 230          }
 231          print $fh qq(  <$type name="$name" modified="$mtime" ts="$ts" />\n);
 232     }
 233     closedir(DH);
 234     print $fh "</files>\n";
 235
 236     finish_xml($fh);
 237 }
 238
 239 # get a repository listing as XML output
 240 sub repo_listing {
 241     my($fh) = @_;
 242
 243     make_xml($fh, "", "", "");
 244
 245     print $fh "<repositories>\n";
 246     opendir(DH, $repository_root);
 247     while( defined (my $name = readdir(DH)) ) {
 248         next if $name =~ /^\.\.?$/;
 249         if (-d "$repository_root/$name/_darcs") {
 250             print $fh qq(  <repository name="$name" />\n);
 251         }
 252     }
 253     closedir(DH);
 254     print $fh "</repositories>\n";
 255
 256     finish_xml($fh);
 257     return $fh;
 258 }
 259
 260 # show an error page
 261 sub show_error {
 262     my ($type, $code, $message) = @_;
 263     my $xml;
 264
 265     # set the xslt processing arguments
 266     my $xslt_args = qq {
 267         --stringparam error-type '$type'
 268         --stringparam stylesheet '$stylesheet'
 269     };
 270     $xslt_args =~ s/\s+/ /gm;
 271
 272     print "Status: $code $message\r\n\r\n";
 273     system("$xslt_program $xslt_args $xslt_errors $xml_errors");
 274 }
 275
 276 # check if the requested resource has been modified since the client last
 277 # saw it. If not send HTTP status code 304, otherwise set the Last-modified
 278 # and Cache-control headers.
 279 sub is_cached {
 280     my ($path) = @_;
 281     my ($stat) = stat($path);
 282
 283     # stat may fail because the path was renamed or deleted but still referred
 284     # to by older darcs patches
 285     if ($stat) {
 286         my $last_modified = CGI::expires($stat->mtime);
 287
 288         if (http('If-Modified-Since') eq $last_modified) {
 289             print("Status: 304 Not Modified\r\n\r\n");
 290             return 1;
 291         }
 292
 293         print("Cache-control: max-age=0, must-revalidate\r\n");
 294         print("Last-modified: $last_modified\r\n");
 295     }
 296     return 0;
 297 }
 298
 299 # safely extract a parameter from the http request.  This applies a regexp
 300 # to the parameter which should group only the appropriate parameter value
 301 sub safe_param {
 302     my ($param, $regex, $default) = @_;
 303     my $value = CGI::Util::unescape(param($param));
 304     return ($value =~ $regex) ? $1 : $default;
 305 }
 306
 307 # common regular expressions for validating passed parameters
 308 my $hash_regex = qr/^([\w\-.]+)$/;
 309 my $path_regex = qr@^([^\\!\$\^&*()\[\]{}<>`|';"?\r\n]+)$@;
 310
 311 # respond to a CGI request
 312 sub respond {
 313     # untaint the full URL to this CGI
 314     my $cgi_url = CGI::Util::unescape(url());
 315     $cgi_url =~ $path_regex or die qq(bad url "$cgi_url");
 316     $cgi_url = $1;
 317
 318     # untaint script_name, reasonable to expect only \w, -, /, and . in the name
 319     my $script_name = CGI::Util::unescape(script_name());
 320     $script_name =~ qr~^([\w/.\-\~]+)$~ or die qq(bad script_name "$script_name");
 321     $script_name = $1;
 322
 323     # untaint simple parameters, which can only have chars matching \w+
 324     my $cmd  = safe_param('c', '^(\w+)$', 'browse');
 325     my $sort = safe_param('s', '^(\w+)$', '');
 326
 327     # set the xslt processing arguments
 328     my $xslt_args = qq {
 329         --stringparam cgi-program '$script_name'
 330         --stringparam cgi-url '$cgi_url'
 331         --stringparam sort-by '$sort'
 332         --stringparam stylesheet '$stylesheet'
 333     };
 334     $xslt_args =~ s/\s+/ /gm;
 335
 336     my ($path) = CGI::Util::unescape(path_info());
 337     # don't allow ./ or ../ in paths
 338     $path =~ s|[.]+/||g;
 339
 340     # check whether we're asking for styles.css
 341     if ($path eq '/styles.css') {
 342         return if is_cached($css_styles);
 343
 344         open (STYLES_CSS, $css_styles) or die qq(couldn't open "${css_styles}");
 345         my $size = stat($css_styles)->size;
 346
 347         print "Content-length: $size\r\n";
 348         print "Content-type: text/css\r\n\r\n";
 349
 350         while (<STYLES_CSS>) {
 351           print $_;
 352         }
 353         close (STYLES_CSS);
 354         return;
 355     }
 356
 357     # check whether we're asking for favicon.ico
 358     if ($path =~ '/[\w\-]+/favicon.ico') {
 359         return if is_cached($favicon);
 360
 361         open (FAVICON, $favicon) or die qq(couldn't open "${favicon}");
 362         my $size = stat($favicon)->size;
 363
 364         print "Content-length: $size\r\n";
 365         print "Content-type: image/x-icon\r\n\r\n";
 366
 367         while (<FAVICON>) {
 368           print $_;
 369         }
 370         close (FAVICON);
 371         return;
 372     }
 373
 374     # when no repository is requested display available repositories
 375     if (length($path) < 2) {
 376         my $fh = transform($xslt_repos, $xslt_args);
 377         repo_listing($fh);
 378         return;
 379     }
 380
 381     # don't allow any shell meta characters in paths
 382     $path =~ $path_regex or die qq(bad path_info "$path");
 383     my @path = split('/', substr($1, 1));
 384
 385     # split the path into a repository, directory, and file
 386     my ($repo, $dir, $file, @bits) = ('', '', '');
 387     while (@path > 0) {
 388         $repo = join('/', @path);
 389         # check if remaining path elements refer to a repo
 390         if (-d "${repository_root}/${repo}/_darcs") {
 391             if (@bits > 1) {
 392                 $dir  = join('/', @bits[0..$#bits - 1]);
 393             }
 394             $file = $bits[$#bits];
 395             # check if last element of path, stored in $file, is really a dir
 396             if (-d (pristine_dir ($repo) . "/${dir}/${file}")) {
 397                 $dir = ($dir ? "$dir/$file" : $file);
 398                 $file = '';
 399             }
 400             last;
 401         } else {
 402             $repo = '';
 403             unshift(@bits, pop @path);
 404         }
 405     }
 406
 407     # make sure the repository exists
 408     unless ($repo) {
 409         show_error('invalid-repository', '404', 'Invalid repository');
 410         return;
 411     }
 412
 413     # don't generate output unless the requested path has been
 414     # modified since the client last saw it.
 415     return if is_cached(pristine_dir ($repo) . "/$dir/$file");
 416
 417     # untaint patches and tags. Tags can have arbitrary values, so
 418     # never pass these unquoted, on pain of pain!
 419     my $patch = safe_param('p', $hash_regex);
 420     my $tag   = safe_param('t', '^(.+)$');
 421
 422     my @darcs_args;
 423     push(@darcs_args, '--match', "hash $patch") if $patch;
 424     push(@darcs_args, '-t', $tag) if $tag;
 425
 426     # process the requested command
 427     if ($cmd eq 'browse') {
 428         my $fh = transform($xslt_browse, $xslt_args);
 429         dir_listing($fh, $repo, $dir);
 430     } elsif ($cmd eq 'patches') {
 431         # patches as an option is used to support "--patches"
 432         if (my $patches = safe_param('patches','^(.+)$')) {
 433             push @darcs_args, '--patches', $patches;
 434         }
 435
 436         my $fh = transform($xslt_patches, $xslt_args);
 437         darcs_xml($fh, $repo, "changes", \@darcs_args, $dir, $file);
 438     } elsif ($cmd eq 'annotate') {
 439         push(@darcs_args, '--summary');
 440
 441         my $creator_hash  = safe_param('ch', $hash_regex);
 442         my $original_path = safe_param('o', $path_regex);
 443         my $fh = transform($xslt_annotate, $xslt_args);
 444
 445         # use the creator hash and original file name when available so
 446         # annotations can span renames
 447         if ($creator_hash ne '' && $original_path ne '') {
 448             push(@darcs_args, '--creator-hash', $creator_hash);
 449             darcs_xml($fh, $repo, "annotate", \@darcs_args, '', $original_path);
 450         } else {
 451             darcs_xml($fh, $repo, "annotate", \@darcs_args, $dir, $file);
 452         }
 453     } elsif ($cmd eq 'diff') {
 454         push(@darcs_args, '-u');
 455         print "Content-type: text/plain\r\n\r\n";
 456         darcs(undef, $repo, "diff", \@darcs_args, $dir, $file);
 457     } elsif ($cmd eq 'rss') {
 458         push(@darcs_args, '--last', '25');
 459
 460         my $fh = transform($xslt_rss, $xslt_args, "application/rss+xml");
 461         darcs_xml($fh, $repo, "changes", \@darcs_args, $dir, $file);
 462     } else {
 463         show_error('invalid-command', '400', 'Invalid command');
 464     }
 465 }
 466
 467 # run a self-test when the --check argument is supplied
 468 if ($ARGV[0] eq '--check') {
 469     (read_conf("css_styles", "abc") ne "abc") ||
 470         die "cannot read config file: $!\n";
 471
 472     (`$darcs_program`) ||
 473         die "cannot execute darcs as '$darcs_program': $!\n";
 474     (`$xslt_program`) ||
 475         die "cannot execute xstlproc as '$xslt_program': $!\n";
 476
 477     (-d $repository_root && -r $repository_root) ||
 478         die "cannot read repository root directory '$repository_root': $!\n";
 479     (-d $template_root && -r $template_root) ||
 480         die "cannot read template root directory '$template_root': $!\n";
 481     (-f $css_styles) ||
 482         die "cannot read css stylesheet '$css_styles': $!\n";
 483     (-f $xml_errors) ||
 484         die "cannot read error messages '$xml_errors': $!\n";
 485
 486     exit 0;
 487 }
 488
 489 # handle the CGI request
 490 respond();
 491