git-browser.cgi

   1 #!/usr/bin/env perl
   2
   3 # (C) 2005, Artem Khodush <greenkaa@gmail.com>
   4 # (C) 2020, Kyle J. McKay <mackyle@gmail.com>
   5 # All rights reserved.
   6
   7 # This program contains parts from gitweb.cgi,
   8 # (C) 2005, Kay Sievers <kay.sievers@vrfy.org>
   9 # (C) 2005, Christian Gierke <ch@gierke.de>
  10
  11 # This program is licensed under the GPL v2, or a later version
  12
  13 use 5.008;
  14 use strict;
  15 no warnings;
  16
  17 package git::inner;
  18
  19 use Encode;
  20 use File::Spec;
  21 use IPC::Open2;
  22 use vars qw($gitdir);
  23
  24 # location of the git-core binaries
  25 $git::inner::gitbin="git";
  26
  27 # opens a "-|" cmd pipe handle with 2>/dev/null and returns it
  28 sub cmd_pipe {
  29         open(NULL, '>', File::Spec->devnull) or die "Cannot open devnull: $!\n";
  30         open(SAVEERR, ">&STDERR") || die "couldn't dup STDERR: $!\n";
  31         open(STDERR, ">&NULL") || die "couldn't dup NULL to STDERR: $!\n";
  32         my $result = open(my $fd, "-|", @_);
  33         open(STDERR, ">&SAVEERR") || die "couldn't dup SAVERR to STDERR: $!\n";
  34         close(SAVEERR) or die "couldn't close SAVEERR: $!\n";
  35         close(NULL) or die "couldn't close NULL: $!\n";
  36         return $result ? $fd : undef;
  37 }
  38
  39 # opens a "|-|" cmd pipe with 2>/dev/null and returns ($pid,$wfd,$rdf)
  40 sub cmd_bidi_pipe {
  41         open(NULL, '>', File::Spec->devnull) or die "Cannot open devnull: $!\n";
  42         open(SAVEERR, ">&STDERR") || die "couldn't dup STDERR: $!\n";
  43         open(STDERR, ">&NULL") || die "couldn't dup NULL to STDERR: $!\n";
  44         my ($pid, $rfd, $wfd);
  45         eval {
  46                 $pid = open2($rfd, $wfd, @_);
  47         };
  48         open(STDERR, ">&SAVEERR") || die "couldn't dup SAVERR to STDERR: $!\n";
  49         close(SAVEERR) or die "couldn't close SAVEERR: $!\n";
  50         close(NULL) or die "couldn't close NULL: $!\n";
  51         return $pid ? ($pid, $wfd, $rfd) : ();
  52 }
  53
  54 # closes a cmd_bidi_pipe if passed the return array from cmd_bidi_pipe
  55 sub cmd_bidi_close {
  56         my ($pid, $wfd, $rfd) = @_;
  57         defined($wfd) and close($wfd);
  58         defined($rfd) and close($rfd);
  59         $pid and waitpid($pid, 0);
  60 }
  61
  62 # opens a "-|" git_cmd pipe handle with 2>/dev/null and returns it
  63 # returns undef and sets a non-zero $! if the pipe is empty
  64 sub git_cmd_pipe {
  65         my $p = cmd_pipe $git::inner::gitbin, "--git-dir=".$gitdir, @_;
  66         defined($p) or return undef;
  67         eof($p) or return $p;
  68         close($p);
  69         my $e = $?;
  70         $e = ($e >= 256) ? ($e > 32768 ? 128 : $e >> 8) : ($e & 0x7f) + 128;
  71         $e or $e = 1;
  72         $! = $e;
  73         return undef;
  74 }
  75
  76 # opens a "-|" git_cmd pipe and returns the entire result as one chomp'd string
  77 # or undef if there was no result or an error
  78 sub git_cmd_value {
  79         my $p = git_cmd_pipe @_;
  80         defined($p) or return undef;
  81         my $result = undef;
  82         {
  83                 local $/;
  84                 $result = <$p>;
  85         }
  86         close($p);
  87         defined($result) and chomp($result);
  88         return $result;
  89 }
  90
  91 my $fallback_encoding;
  92 BEGIN {
  93         $fallback_encoding = Encode::find_encoding('Windows-1252');
  94         $fallback_encoding = Encode::find_encoding('ISO-8859-1')
  95                 unless $fallback_encoding;
  96 }
  97
  98 # decode sequences of octets in utf8 into Perl's internal form,
  99 # which is utf-8 with utf8 flag set if needed.  git-browser writes out
 100 # in utf-8 thanks to "binmode STDOUT, ':utf8'" at beginning
 101 sub to_utf8 {
 102         my $str = shift || '';
 103         if (Encode::is_utf8($str) || utf8::decode($str)) {
 104                 return $str;
 105         } else {
 106                 return $fallback_encoding->decode($str, Encode::FB_DEFAULT);
 107         }
 108 }
 109
 110 sub git_master_branch
 111 {
 112         my $head_id = git_cmd_value 'rev-parse', '--verify', 'HEAD', '--';
 113         defined($head_id) && $head_id =~ /^[0-9a-f]{40,}$/ or return undef;
 114         my $head_sym = git_cmd_value 'symbolic-ref', '-q', 'HEAD';
 115         defined($head_sym) and $head_sym = to_utf8($head_sym);
 116         return "HEAD" unless defined($head_sym) && $head_sym =~ m{^refs/heads/(.+)$};
 117         return $1;
 118 }
 119
 120 sub git_read_commits
 121 {
 122         no strict 'refs';
 123         my $arg=shift;
 124         my $MAX_COUNT= $arg->{shortcomment} ? 400 : 200;
 125         my @command=('rev-list', '--stdin', '--header', '--parents', '--date-order', "--max-count=$MAX_COUNT", '--');
 126         my @input=(@{$arg->{id}}, map("^$_", @{$arg->{x}}));
 127         push(@input, '--');
 128         push(@input, @{$arg->{path}}) if @{$arg->{path}};
 129
 130         my %commits;
 131
 132         local $/ = "\0";
 133         my ($pid, $wfd, $rfd) = cmd_bidi_pipe($git::inner::gitbin, "--git-dir=".$gitdir, @command);
 134         $pid or die "git_read_commits: error running git rev-list: @{[0+$!]}\n";
 135         binmode $wfd;
 136         binmode $rfd;
 137         {
 138                 local $SIG{'PIPE'} = sub {};
 139                 print $wfd map("$_\n", @input)
 140                         or cmd_bidi_close($pid, $wfd, $rfd), die "git_read_commits: git rev-list --stdin failed: $!\n";
 141         }
 142         close($wfd); $wfd = undef;
 143         while( my $commit_line=<$rfd> ) {
 144                 $commit_line =~ s/\r$//;
 145                 my @commit_lines = ();
 146                 foreach (split '\n', $commit_line) {
 147                         push @commit_lines, to_utf8($_);
 148                 }
 149                 pop @commit_lines;
 150                 my %co;
 151
 152                 my $header = shift @commit_lines;
 153                 if (!($header =~ m/^[0-9a-fA-F]{40}/)) {
 154                         next;
 155                 }
 156                 ($co{'id'}, my @parents) = split ' ', $header;
 157                 $co{'parents'} = \@parents;
 158                 while (my $line = shift @commit_lines) {
 159                         last if $line eq "\n";
 160 # minimize http traffic - do not read not used things
 161 #                       if ($line =~ m/^tree ([0-9a-fA-F]{40})$/) {
 162 #                               $co{'tree'} = $1;
 163 #                       } els
 164                         if ($line =~ m/^author (.*) ([0-9]+) (.*)$/) {
 165                                 $co{'author'} = $1;
 166                                 $co{'author_epoch'} = $2;
 167 #                               $co{'author_tz'} = $3;
 168                         }elsif ($line =~ m/^committer (.*) ([0-9]+) (.*)$/) {
 169 #                               $co{'committer'} = $1;
 170                                 $co{'committer_epoch'} = $2;
 171 #                               $co{'committer_tz'} = $3;
 172                         }
 173                 }
 174 #               if (!defined $co{'tree'}) {
 175 #                       next;
 176 #               };
 177
 178                 # remove added spaces
 179                 foreach my $line (@commit_lines) {
 180                         $line =~ s/^    //;
 181                 }
 182                 if( $arg->{shortcomment} ) {
 183                         $co{'comment'} = [$commit_lines[0]];
 184                 }else {
 185                         $co{'comment'} = \@commit_lines;
 186                 }
 187
 188                 $commits{$co{'id'}}=\%co;
 189         }
 190         cmd_bidi_close($pid, $wfd, $rfd);
 191
 192         return \%commits;
 193 }
 194
 195 sub get_ref_ids
 196 {
 197         defined(my $fd = git_cmd_pipe 'show-ref', '--head', '--dereference') or
 198                 die "get_ref_ids: error running git show-ref: @{[0+$!]}\n";
 199         my @refs;
 200         my %names;
 201         my $tagcnt = 0;
 202         while( my $line=<$fd> ) {
 203                 chomp $line;
 204                 my ($id,$name)=split /[ \t]+/, to_utf8($line);
 205                 if( $name=~s/^refs\/heads\/// || $name eq "HEAD" ) {
 206                         push @refs, { type=>"h", id=>$id, name=>$name };
 207                 }elsif( $name=~s/^refs\/tags\/// ) {
 208                         my $deref=0;
 209                         if( $name=~m/\^\{\w*\}$/ ) { # it's dereferenced
 210                                 $deref=1;
 211                                 $name=$`;
 212                         }
 213                         # if several ids for a name is seen, we are interested only in the last dereferenced one
 214                         ++$tagcnt, $names{$name}={} unless exists $names{$name};
 215                         $names{$name}->{$deref}=$id;
 216                         push @refs, { type=>"t", id=>$id, name=>$name };
 217                 }
 218         }
 219         close $fd;
 220
 221         # keep only commits
 222
 223         my ($pid, $wfd, $rfd);
 224         local $SIG{'PIPE'} = sub {};
 225         if ($tagcnt) {
 226                 ($pid, $wfd, $rfd) = cmd_bidi_pipe($git::inner::gitbin, "--git-dir=".$gitdir, 'cat-file', '--batch-check');
 227                 $pid or die "get_ref_ids: unable to run git cat-file --batch-check\n";
 228         }
 229         my $git_get_type = sub {
 230                 return "" unless $tagcnt;
 231                 my $id = shift;
 232                 defined($id) && $id ne "" or return "";
 233                 print $wfd $id, "\n" or cmd_bidi_close($pid, $wfd, $rfd), die "get_ref_ids: git cat-file --batch-check failed: $!\n";
 234                 my $bcl = <$rfd>;
 235                 defined($bcl) or return "";
 236                 my @bcl = split(' ', $bcl);
 237                 @bcl >= 2 or return "";
 238                 return $bcl[1];
 239         };
 240         my @result;
 241         for my $ref (@refs) {
 242                 if( $ref->{type} eq "h" ) {
 243                         # assume all heads are commits
 244                         push @result, $ref;
 245                 }else {
 246                         my $id_kind=$names{$ref->{name}};
 247                         # so. if several ids for a name is seen, keep only in the last dereferenced one
 248                         if( $ref->{id} eq $id_kind->{1} || ($ref->{id} eq $id_kind->{0} && !exists $id_kind->{1}) ) {
 249                                 # and only if it's a commit
 250                                 push @result, $ref if &$git_get_type( $ref->{id} ) eq "commit";
 251                         }
 252                 }
 253         }
 254         cmd_bidi_close($pid, $wfd, $rfd) if $tagcnt;
 255         return \@result;
 256 }
 257
 258 package git;
 259
 260 sub get_ref_names
 261 {
 262         my $refs=git::inner::get_ref_ids;
 263         my $result={ tags=>[], heads=>[] };
 264         for my $ref (@$refs) {
 265                 push @{$result->{tags}}, $ref->{name} if $ref->{type} eq "t";
 266                 push @{$result->{heads}}, $ref->{name} if $ref->{type} eq "h";
 267         }
 268         return $result;
 269 }
 270
 271 sub commits_from_refs
 272 {
 273         my $arg=shift;
 274         # can't just do git_read_commits. mapping from ref names to ids must also be returned for labels to work.
 275         my $refs=git::inner::get_ref_ids;
 276         my @start_ids;
 277         for (@{$arg->{ref}}) {
 278                 my ($type,$name)=split ",";
 279                 $name = git::inner::to_utf8($name);
 280                 if( "r" eq $type ) {
 281                         push @start_ids, $_->{id} for (grep( $_->{type} =~ /^[ht]$/, @$refs )); # all heads & tags
 282                 }else {
 283                         push @start_ids, $_->{id} for (grep( $name eq $_->{name} && $type eq $_->{type}, @$refs ));
 284                 }
 285         }
 286         my $master=git::inner::git_master_branch;
 287         my $ans = { refs=>$refs, commits=>commits_from_ids( { id=>\@start_ids, x=>$arg->{x}, path=>$arg->{path}, shortcomment=>$arg->{shortcomment} } ) };
 288         defined($master) && $master ne "" and $ans->{master} = $master;
 289         return $ans;
 290 }
 291
 292 sub commits_from_ids
 293 {
 294         my $arg=shift;
 295         return git::inner::git_read_commits( $arg );
 296 }
 297
 298 package inner;
 299
 300 # Set the global doconfig setting in the GITBROWSER_CONFIG file to the full
 301 # path to a perl source file to run to alter these settings
 302
 303 # If $check_path is set to a subroutine reference, it will be called
 304 # by get_repo_path with two arguments, the name of the repo and its
 305 # path which will be undef if it's not a known repo.  If the function
 306 # returns false, access to the repo will be denied.
 307 # $check_path = sub { my ($name, $path) = @_; $name ~! /restricted/i; };
 308 use vars qw($check_path);
 309
 310 use Cwd qw(abs_path);
 311 use File::Basename qw(dirname);
 312 use File::Spec::Functions qw(file_name_is_absolute catdir);
 313
 314 sub read_config
 315 {
 316         my $f;
 317         my $GITBROWSER_CONFIG = $ENV{'GITBROWSER_CONFIG'} || "git-browser.conf";
 318         -e $GITBROWSER_CONFIG or $GITBROWSER_CONFIG = "/etc/git-browser.conf";
 319
 320         open $f, '<', $GITBROWSER_CONFIG or return;
 321         my $confdir = dirname(abs_path($GITBROWSER_CONFIG));
 322         my $section="";
 323         my $configfile="";
 324         while( <$f> ) {
 325                 chomp;
 326                 $_=~ s/\r$//;
 327                 if( $section eq "repos" ) {
 328                         if( m/^\w+:\s*/ ) {
 329                                 $section="";
 330                                 redo;
 331                         }else {
 332                                 my ($name,$path)=split;
 333                                 if( $name && $path ) {
 334                                         file_name_is_absolute($path) or
 335                                                 $path = catdir($confdir, $path);
 336                                         $inner::known_repos{$name}=$path;
 337                                 }
 338                         }
 339                 }else {
 340                         if( m/^gitbin:\s*/ ) {
 341                                 $git::inner::gitbin=$';
 342                         }elsif( m/^path:\s*/ ) {
 343                                 $ENV{PATH}=$';
 344                         }elsif( m/^http_expires:\s*/ ) {
 345                                 $inner::http_expires=$';
 346                         }elsif( m/^warehouse:\s*/ ) {
 347                                 my $path = $';
 348                                 file_name_is_absolute($path) or
 349                                         $path = catdir($confdir, $path);
 350                                 $inner::warehouse=$path;
 351                         }elsif( m/^doconfig:\s*/ ) {
 352                                 $configfile=$';
 353                         }elsif( m/^repos:\s*/ ) {
 354                                 $section="repos";
 355                         }
 356                 }
 357         }
 358         if ($configfile && -e $configfile) {
 359                 do $configfile;
 360                 die $@ if $@;
 361         }
 362 }
 363
 364 package main;
 365
 366 use Cwd qw(abs_path);
 367 use File::Basename qw(dirname);
 368 use File::Spec::Functions qw(catdir);
 369 use CGI qw(:standard :escapeHTML -nosticky);
 370 use CGI::Util qw(unescape);
 371 use CGI::Carp qw(fatalsToBrowser);
 372 BEGIN {
 373         eval 'sub CGI::multi_param {CGI::param(@_)}'
 374                 unless CGI->can("multi_param");
 375 }
 376 BEGIN {dirname(abs_path($0)) =~ m{^(.+)$}os and eval 'use lib $1'}
 377 use JSON::Converter;
 378
 379 binmode STDOUT, ':utf8';
 380
 381 sub get_repo_path
 382 {
 383         my ($name) = @_;
 384         my $path = $inner::known_repos{$name};
 385         return undef
 386             if ref($inner::check_path) eq 'CODE' && !&{$inner::check_path}($name, $path);
 387         if (not defined $path and $inner::warehouse and -d catdir($inner::warehouse, $name)) {
 388                 $path = catdir($inner::warehouse, $name);
 389         }
 390         return $path;
 391 }
 392
 393 sub get_repo_names
 394 {
 395         my @a=sort({lc($a) cmp lc($b) || $a cmp $b} keys %inner::known_repos);
 396         return \@a;
 397 }
 398 sub validate_input {
 399         my $input = shift;
 400
 401         if ($input =~ m/^[0-9a-fA-F]{40,}$/) {
 402                 return $input;
 403         }
 404         if ($input =~ m/(?:^|\/)(?:|\.|\.\.)(?:$|\/)/) {
 405                 return undef;
 406         }
 407         if ($input =~ m/[^a-zA-Z0-9_\x80-\xff\ \t\.\/\-\+\*\~\%\,\x21-\x7e]/) {
 408                 return undef;
 409         }
 410         return $input;
 411 }
 412
 413 inner::read_config();
 414
 415 my $converter=JSON::Converter->new;
 416 my $request=CGI::new();
 417
 418 my $repo;
 419 my $sub;
 420 my $arg={};
 421
 422 my $result="null";
 423 my $error="null";
 424
 425 my @names=$request->multi_param;
 426 for my $pn (@names) {
 427         if( $pn eq "repo" ) {
 428                 $repo=$request->param( "repo" );
 429         }elsif( $pn eq "sub" ) {
 430                 $sub=$request->param( "sub" );
 431         }else {
 432                 my @v=$request->multi_param( $pn );
 433                 for my $v (@v) {
 434                         $error=$converter->valueToJson( "invalid cgi param value for '$pn': '$v'\n" ) unless defined validate_input( $v );
 435                 }
 436                 $arg->{$pn}=\@v;
 437         }
 438 }
 439
 440 if( $error eq "null" ) {
 441         if( !defined( $sub ) ) {
 442                 $error=$converter->valueToJson( "git-browser.cgi: 'sub' cgi parameter is omitted" );
 443         }elsif( exists $main::{$sub} ) {
 444                 eval {
 445                         $result=&{$main::{$sub}}( $arg );
 446                 };
 447                 if( $@ ) {
 448                         $error=$converter->valueToJson( "error in main::$sub: $@" );
 449                 }else {
 450                         $result=$converter->objToJson( $result );
 451                 }
 452         }elsif( exists $git::{$sub} ) {
 453                 if( !defined( $repo ) ) {
 454                         $error=$converter->valueToJson( "git-browser.cgi: 'repo' cgi parameter is omitted" );
 455                 }elsif( !get_repo_path($repo) ) {
 456                         $error=$converter->valueToJson( "git-browser.cgi: unknown repository name specified: $repo" );
 457                 }else {
 458                         local $git::inner::gitdir=get_repo_path($repo);
 459                         eval {
 460                                 $result=&{$git::{$sub}}( $arg );
 461                         };
 462                         if( $@ ) {
 463                                 $error=$converter->valueToJson( "error in git::$sub: $@" );
 464                         }else {
 465                                 $result=$converter->objToJson( $result );
 466                         }
 467                 }
 468         }else {
 469                 $error=$converter->valueToJson( "git-browser.cgi: no procedure '$sub' in either git or main package" );
 470         }
 471 }
 472
 473 print $request->header(-type=>'text/html',  -charset => 'utf-8', -status=> "200 OK", -expires => $inner::http_expires);
 474
 475 print <<EOF;
 476 <html xmlns="http://www.w3.org/1999/xhtml">
 477 <head>
 478 <meta charset="utf-8" />
 479 <meta http-equiv="content-type" content="text/html; charset=utf-8" />
 480 <script type="text/javascript">
 481 /* <![CDATA[ */
 482 document.error=$error;
 483 document.result=$result;
 484 /* ]]> */
 485 </script>
 486 </head>
 487 <body>
 488 </body>
 489 </html>
 490 EOF
 491
 492 0;