git-browser.cgi

   1 #! /usr/bin/perl
   2
   3 # (C) 2005, Artem Khodush <greenkaa@gmail.com>
   4
   5 # This program contains parts from gitweb.cgi,
   6 # (C) 2005, Kay Sievers <kay.sievers@vrfy.org>
   7 # (C) 2005, Christian Gierke <ch@gierke.de>
   8
   9 # This program is licensed under the GPL v2, or a later version
  10
  11 package git::inner;
  12
  13 use File::Spec;
  14
  15 # location of the git-core binaries
  16 $git::inner::gitbin="git";
  17 $git::inner::git_temp="tmp";
  18
  19 # opens a "-|" cmd pipe handle with 2>/dev/null and returns it
  20 sub cmd_pipe {
  21         open(NULL, ">", File::Spec->devnull) or die "Cannot open devnull: $!";
  22         open(SAVEERR, ">&STDERR") || die "couldn't dup STDERR: $!";
  23         open(STDERR, ">&NULL") || die "couldn't dup NULL to STDERR: $!";
  24         my $result = open(my $fd, "-|", @_);
  25         open(STDERR, ">&SAVEERR") || die "couldn't dup SAVERR to STDERR: $!";
  26         close(SAVEERR) or die "couldn't close SAVEERR: $!";
  27         close(NULL) or die "couldn't close NULL: $!";
  28         return $result ? $fd : undef;
  29 }
  30
  31 # opens a "-|" git_cmd pipe handle with 2>/dev/null and returns it
  32 sub git_cmd_pipe {
  33         return cmd_pipe "${git::inner::gitbin}", @_;
  34 }
  35
  36 my $fallback_encoding = '';
  37 INIT {
  38         $fallback_encoding = Encode::find_encoding('Windows-1252');
  39         $fallback_encoding = Encode::find_encoding('ISO-8859-1')
  40                 unless $fallback_encoding;
  41 }
  42
  43 # decode sequences of octets in utf8 into Perl's internal form,
  44 # which is utf-8 with utf8 flag set if needed.  git-browser writes out
  45 # in utf-8 thanks to "binmode STDOUT, ':utf8'" at beginning
  46 sub to_utf8 {
  47         my $str = shift || '';
  48         if (utf8::valid($str)) {
  49                 utf8::decode($str);
  50                 return $str;
  51         } else {
  52                 return Encode::decode($fallback_encoding, $str, Encode::FB_DEFAULT);
  53         }
  54 }
  55
  56 sub git_get_type
  57 {
  58         my $hash = shift;
  59         defined(my $fd = git_cmd_pipe "cat-file", '-t', $hash) or die "git_get_type: error running git cat-file: $!";
  60         my $type = <$fd>;
  61         close $fd;
  62         chomp $type;
  63         $type =~ s/\r$//;
  64         return $type;
  65 }
  66
  67 sub git_read_commits
  68 {
  69         my $arg=shift;
  70         my $MAX_COUNT= $arg->{shortcomment} ? 400 : 200;
  71         my @command=("GIT_DIR=$ENV{'GIT_DIR'} ${git::inner::gitbin}", "rev-list", '--header', '--parents', "--max-count=$MAX_COUNT");
  72         push(@command, @{$arg->{id}}, @{$arg->{x}});
  73         push(@command, '--', @{$arg->{path}}) if @{$arg->{path}};
  74
  75         my %commits;
  76
  77         $/ = "\0";
  78         defined(my $fd = cmd_pipe "@command") or die "git_read_commits: error running git rev-list: $!";
  79         binmode $fd;
  80         while( my $commit_line=<$fd> ) {
  81                 $commit_line =~ s/\r$//;
  82                 my @commit_lines = ();
  83                 foreach (split '\n', $commit_line) {
  84                         push @commit_lines, to_utf8($_);
  85                 }
  86                 pop @commit_lines;
  87                 my %co;
  88
  89                 my $header = shift @commit_lines;
  90                 if (!($header =~ m/^[0-9a-fA-F]{40}/)) {
  91                         next;
  92                 }
  93                 ($co{'id'}, my @parents) = split ' ', $header;
  94                 $co{'parents'} = \@parents;
  95                 while (my $line = shift @commit_lines) {
  96                         last if $line eq "\n";
  97 # minimize http traffic - do not read not used things
  98 #                       if ($line =~ m/^tree ([0-9a-fA-F]{40})$/) {
  99 #                               $co{'tree'} = $1;
 100 #                       } els
 101                         if ($line =~ m/^author (.*) ([0-9]+) (.*)$/) {
 102                                 $co{'author'} = $1;
 103                                 $co{'author_epoch'} = $2;
 104 #                               $co{'author_tz'} = $3;
 105                         }elsif ($line =~ m/^committer (.*) ([0-9]+) (.*)$/) {
 106 #                               $co{'committer'} = $1;
 107                                 $co{'committer_epoch'} = $2;
 108 #                               $co{'committer_tz'} = $3;
 109                         }
 110                 }
 111 #               if (!defined $co{'tree'}) {
 112 #                       next;
 113 #               };
 114
 115                 # remove added spaces
 116                 foreach my $line (@commit_lines) {
 117                         $line =~ s/^    //;
 118                 }
 119                 if( $arg->{shortcomment} ) {
 120                         $co{'comment'} = [$commit_lines[0]];
 121                 }else {
 122                         $co{'comment'} = \@commit_lines;
 123                 }
 124
 125                 $commits{$co{'id'}}=\%co;
 126         }
 127         close $fd;
 128         $/ = "\n";
 129
 130         return \%commits;
 131 }
 132
 133
 134 sub get_ref_ids
 135 {
 136         my $repo=$ENV{'GIT_DIR'};
 137         my $exec="\"";
 138         $exec.="PATH=$ENV{PATH} " if $ENV{PATH};
 139         $exec.="GIT_EXEC_PATH=$ENV{GIT_EXEC_PATH} " if $ENV{GIT_EXEC_PATH};
 140         $exec.="${git::inner::gitbin} upload-pack\"";
 141         defined(my $fd = cmd_pipe "${git::inner::gitbin} ls-remote --upload-pack=$exec $repo") or die "get_ref_ids: error running git ls-remote: $!";
 142         my @refs;
 143         my %names;
 144         while( my $line=<$fd> ) {
 145                 my ($id,$name)=split ' ', $line;
 146                 if( $name=~s/^refs\/heads\/// ) {
 147                         push @refs, { type=>"h", id=>$id, name=>$name };
 148                 }elsif( $name=~s/^refs\/tags\/// ) {
 149                         my $deref=0;
 150                         if( $name=~m/\^\{\w*\}$/ ) { # it's dereferenced
 151                                 $deref=1;
 152                                 $name=$`;
 153                         }
 154                         # if several ids for a name is seen, we are interested only in the last dereferenced one
 155                         $names{$name}={} unless exists $names{$name};
 156                         $names{$name}->{$deref}=$id;
 157                         push @refs, { type=>"t", id=>$id, name=>$name };
 158                 }
 159         }
 160         close $fd;
 161         # keep only commits
 162         my @result;
 163         for my $ref (@refs) {
 164                 if( $ref->{type} eq "h" ) {
 165                         # assume all heads are commits
 166                         push @result, $ref;
 167                 }else {
 168                         my $id_kind=$names{$ref->{name}};
 169                         # so. if several ids for a name is seen, keep only in the last dereferenced one
 170                         if( $ref->{id} eq $id_kind->{1} || ($ref->{id} eq $id_kind->{0} && !exists $id_kind->{1}) ) {
 171                                 # and only if it's a commit
 172                                 push @result, $ref if git_get_type( $ref->{id} ) eq "commit";
 173                         }
 174                 }
 175         }
 176         return \@result;
 177 }
 178
 179 package git;
 180
 181 sub get_ref_names
 182 {
 183         my $refs=git::inner::get_ref_ids;
 184         my $result={ tags=>[], heads=>[] };
 185         for my $ref (@$refs) {
 186                 push @{$result->{tags}}, $ref->{name} if $ref->{type} eq "t";
 187                 push @{$result->{heads}}, $ref->{name} if $ref->{type} eq "h";
 188         }
 189         return $result;
 190 }
 191
 192 sub commits_from_refs
 193 {
 194         my $arg=shift;
 195         # can't just do git_read_commits. mapping from ref names to ids must also be returned for labels to work.
 196         my $refs=git::inner::get_ref_ids;
 197         my @start_ids;
 198         for (@{$arg->{ref}}) {
 199                 my ($type,$name)=split ",";
 200                 if( "r" eq $type ) {
 201                         push @start_ids, $_->{id} for (grep( "h" eq $_->{type}, @$refs )); # all heads
 202                 }else {
 203                         push @start_ids, $_->{id} for (grep( $name eq $_->{name} && $type eq $_->{type}, @$refs ));
 204                 }
 205         }
 206         return { refs=>$refs, commits=>commits_from_ids( { id=>\@start_ids, x=>$arg->{x}, path=>$arg->{path}, shortcomment=>$arg->{shortcomment} } ) };
 207 }
 208
 209 sub commits_from_ids
 210 {
 211         my $arg=shift;
 212         return git::inner::git_read_commits( $arg );
 213 }
 214
 215 package inner;
 216
 217 sub read_config
 218 {
 219         my $f;
 220         if (-e "git-browser.conf") {
 221                 open $f, "< git-browser.conf" or return;
 222         } else {
 223                 open $f, "< /etc/git-browser.conf" or return;
 224         }
 225         my $section="";
 226         while( <$f> ) {
 227                 chomp;
 228                 $_=~ s/\r$//;
 229                 if( $section eq "repos" ) {
 230                         if( m/^\w+:\s*/ ) {
 231                                 $section="";
 232                                 redo;
 233                         }else {
 234                                 my ($name,$path)=split;
 235                                 if( $name && $path ) {
 236                                         $inner::known_repos{$name}=$path;
 237                                 }
 238                         }
 239                 }else {
 240                         if( m/^gitbin:\s*/ ) {
 241                                 $git::inner::gitbin=$';
 242                                 $ENV{GIT_EXEC_PATH}=$';
 243                         }elsif( m/^path:\s*/ ) {
 244                                 $ENV{PATH}=$';
 245                         }elsif( m/^http_expires:\s*/ ) {
 246                                 $inner::http_expires=$';
 247                         }elsif( m/^git_temp:\s*/ ) {
 248                                 $git::inner::git_temp=$';
 249                         }elsif( m/^warehouse:\s*/ ) {
 250                                 $inner::warehouse=$';
 251                         }elsif( m/^repos:\s*/ ) {
 252                                 $section="repos";
 253                         }
 254                 }
 255         }
 256 }
 257
 258
 259 package main;
 260
 261 use JSON::Converter;
 262 use CGI qw(:standard :escapeHTML -nosticky);
 263 use CGI::Util qw(unescape);
 264 use CGI::Carp qw(fatalsToBrowser);
 265 BEGIN {
 266         if( $^V ge v5.8.0 ) {
 267                 require Encode; import Encode;
 268                 require Fcntl; import Fcntl ':mode';
 269         }else {
 270                 no strict "refs";
 271                 *{"Encode::FB_DEFAULT"}=sub { 1; };
 272                 *{"Encode::decode"}=sub { my ($a,$s,$b)=@_; return $s; };
 273                 *{"Encode::find_encoding"}=sub { return undef; };
 274         }
 275 }
 276
 277 if( $^V ge v5.8.0 ) {
 278         binmode STDOUT, ':utf8';
 279 }
 280
 281 sub get_repo_path
 282 {
 283         my ($name) = @_;
 284         my $path = $inner::known_repos{$name};
 285         if (not defined $path and $inner::warehouse and -d $inner::warehouse.'/'.$name) {
 286                 $path = $inner::warehouse.'/'.$name;
 287         }
 288         return $path;
 289 }
 290
 291 sub get_repo_names
 292 {
 293         my @a=keys %inner::known_repos;
 294         return \@a;
 295 }
 296 sub validate_input {
 297         my $input = shift;
 298
 299         if ($input =~ m/^[0-9a-fA-F]{40}$/) {
 300                 return $input;
 301         }
 302         if ($input =~ m/(^|\/)(|\.|\.\.)($|\/)/) {
 303                 return undef;
 304         }
 305         if ($input =~ m/[^a-zA-Z0-9_\x80-\xff\ \t\.\/\-\+\*\~\%\,]/) {
 306                 return undef;
 307         }
 308         return $input;
 309 }
 310
 311
 312
 313 inner::read_config();
 314
 315 my $converter=JSON::Converter->new;
 316 my $request=CGI::new();
 317
 318 my $repo;
 319 my $sub;
 320 my $arg={};
 321
 322 my $result="null";
 323 my $error="null";
 324
 325 my @names=$request->param;
 326 for my $pn (@names) {
 327         if( $pn eq "repo" ) {
 328                 $repo=$request->param( "repo" );
 329         }elsif( $pn eq "sub" ) {
 330                 $sub=$request->param( "sub" );
 331         }else {
 332                 my @v=$request->param( $pn );
 333                 for my $v (@v) {
 334                         $error=$converter->valueToJson( "invalid cgi param value for '$pn': '$v'\n" ) unless defined validate_input( $v );
 335                 }
 336                 $arg->{$pn}=\@v;
 337         }
 338 }
 339
 340 if( $error eq "null" ) {
 341         if( !defined( $sub ) ) {
 342                 $error=$converter->valueToJson( "git-browser.pl: 'sub' cgi parameter is omitted" );
 343         }elsif( exists $main::{$sub} ) {
 344                 eval {
 345                         $result=&{$main::{$sub}}( $arg );
 346                 };
 347                 if( $@ ) {
 348                         $error=$converter->valueToJson( "error in main::$sub: $@" );
 349                 }else {
 350                         $result=$converter->objToJson( $result );
 351                 }
 352         }elsif( exists $git::{$sub} ) {
 353                 if( !defined( $repo ) ) {
 354                         $error=$converter->valueToJson( "git-browser.pl: 'repo' cgi parameter is omitted" );
 355                 }elsif( !get_repo_path($repo) ) {
 356                         $error=$converter->valueToJson( "git-browser.pl: unknown repository name specified: $repo" );
 357                 }else {
 358                         $ENV{'GIT_DIR'}=get_repo_path($repo);
 359                         eval {
 360                                 $result=&{$git::{$sub}}( $arg );
 361                         };
 362                         if( $@ ) {
 363                                 $error=$converter->valueToJson( "error in git::$sub: $@" );
 364                         }else {
 365                                 $result=$converter->objToJson( $result );
 366                         }
 367                 }
 368         }else {
 369                 $error=$converter->valueToJson( "git-browser.pl: no procedure '$sub' in either git or main package" );
 370         }
 371 }
 372
 373 print $request->header(-type=>'text/html',  -charset => 'utf-8', -status=> "200 OK", -expires => $inner::http_expires);
 374
 375 print <<EOF;
 376 <html>
 377 <head>
 378 <script type="text/javascript">
 379 document.error=$error;
 380 document.result=$result;
 381 </script>
 382 </head>
 383 <body>
 384 </body>
 385 </html>
 386 EOF
 387
 388 0;