lib/Gitalist/Model/Git.pm

   1 package Gitalist::Model::Git;
   2
   3 use Moose;
   4 use namespace::autoclean;
   5
   6 BEGIN { extends 'Catalyst::Model' }
   7
   8 use DateTime;
   9 use Path::Class;
  10 use Carp qw/croak/;
  11 use File::Find::Rule;
  12 use DateTime::Format::Mail;
  13 use File::Stat::ModeString;
  14 use List::MoreUtils qw/any/;
  15 use Scalar::Util qw/blessed/;
  16
  17 use Gitalist::Util qw(to_utf8);
  18
  19 # from gitweb.pm
  20 use CGI::Util qw(unescape);
  21
  22 has git => (
  23         is      => 'ro',
  24         isa     => 'Str',
  25         lazy    => 1,
  26         default => sub {
  27                 my $git;
  28
  29                 if (my $config_git = Gitalist->config->{git}) {
  30                         $git = $config_git if -x $config_git;
  31                 }
  32                 else {
  33                         require File::Which;
  34                         $git = File::Which::which('git');
  35                 }
  36
  37                 if (!$git) {
  38                         die <<EOR
  39 Could not find a git executable.
  40 Please specify the which git executable to use in gitweb.yml
  41 EOR
  42                 }
  43
  44                 return $git;
  45         },
  46 );
  47
  48 sub is_git_repo {
  49     my ($self, $dir) = @_;
  50
  51     #FIXME: Only handles bare repos. Is that enough?
  52     return -f $dir->file('HEAD');
  53 }
  54
  55 sub project_info {
  56     my ($self, $project) = @_;
  57
  58     return {
  59         name => $project,
  60         $self->get_project_properties(
  61                 $self->git_dir_from_project_name($project),
  62         ),
  63     };
  64 }
  65
  66 sub get_project_properties {
  67     my ($self, $dir) = @_;
  68     my %props;
  69
  70     eval {
  71         $props{description} = $dir->file('description')->slurp;
  72         chomp $props{description};
  73     };
  74
  75     if ($props{description} =~ /^Unnamed repository;/) {
  76         delete $props{description};
  77     }
  78
  79     $props{owner} = (getpwuid $dir->stat->uid)[6];
  80
  81     my $output = $self->run_cmd_in($dir, qw{
  82             for-each-ref --format=%(committer)
  83             --sort=-committerdate --count=1 refs/heads
  84     });
  85
  86     if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) {
  87         my $dt = DateTime->from_epoch(epoch => $epoch);
  88         $dt->set_time_zone($tz);
  89         $props{last_change} = $dt;
  90     }
  91
  92     return %props;
  93 }
  94
  95 sub list_projects {
  96     my ($self) = @_;
  97
  98     my $base = dir(Gitalist->config->{repo_dir});
  99
 100     my @ret;
 101     my $dh = $base->open;
 102     while (my $file = $dh->read) {
 103         next if $file =~ /^.{1,2}$/;
 104
 105         my $obj = $base->subdir($file);
 106         next unless -d $obj;
 107         next unless $self->is_git_repo($obj);
 108
 109         push @ret, {
 110             name => ($obj->dir_list)[-1],
 111             $self->get_project_properties($obj),
 112         };
 113     }
 114
 115     return \@ret;
 116 }
 117
 118 sub run_cmd {
 119     my ($self, @args) = @_;
 120
 121     open my $fh, '-|', __PACKAGE__->git, @args
 122         or die "failed to run git command";
 123     binmode $fh, ':encoding(UTF-8)';
 124
 125     my $output = do { local $/ = undef; <$fh> };
 126     close $fh;
 127
 128     return $output;
 129 }
 130
 131 sub run_cmd_in {
 132     my ($self, $project, @args) = @_;
 133
 134     my $path;
 135     if (blessed($project) && $project->isa('Path::Class::Dir')) {
 136         $path = $project->stringify;
 137     }
 138     else {
 139         $path = $self->git_dir_from_project_name($project);
 140     }
 141     return $self->run_cmd('--git-dir' => $path, @args);
 142 }
 143
 144 sub git_dir_from_project_name {
 145     my ($self, $project) = @_;
 146
 147     return dir(Gitalist->config->{repo_dir})->subdir($project);
 148 }
 149
 150 sub get_head_hash {
 151     my ($self, $project) = @_;
 152
 153     my $output = $self->run_cmd_in($project, qw/rev-parse --verify HEAD/ );
 154     return unless defined $output;
 155
 156     my ($head) = $output =~ /^([0-9a-fA-F]{40})$/;
 157     return $head;
 158 }
 159
 160 sub list_tree {
 161     my ($self, $project, $rev) = @_;
 162
 163     $rev ||= $self->get_head_hash($project);
 164
 165     my $output = $self->run_cmd_in($project, qw/ls-tree -z/, $rev);
 166     return unless defined $output;
 167
 168     my @ret;
 169     for my $line (split /\0/, $output) {
 170         my ($mode, $type, $object, $file) = split /\s+/, $line, 4;
 171
 172         push @ret, {
 173             mode   => oct $mode,
 174             type   => $type,
 175             object => $object,
 176             file   => $file,
 177         };
 178     }
 179
 180     return @ret;
 181 }
 182
 183 sub get_object_mode_string {
 184     my ($self, $object) = @_;
 185
 186     return unless $object && $object->{mode};
 187     return mode_to_string($object->{mode});
 188 }
 189
 190 sub get_object_type {
 191     my ($self, $project, $object) = @_;
 192
 193     my $output = $self->run_cmd_in($project, qw/cat-file -t/, $object);
 194     return unless $output;
 195
 196     chomp $output;
 197     return $output;
 198 }
 199
 200 sub cat_file {
 201     my ($self, $project, $object) = @_;
 202
 203     my $type = $self->get_object_type($project, $object);
 204     die "object `$object' is not a file\n"
 205         if (!defined $type || $type ne 'blob');
 206
 207     my $output = $self->run_cmd_in($project, qw/cat-file -p/, $object);
 208     return unless $output;
 209
 210     return $output;
 211 }
 212
 213 sub valid_rev {
 214     my ($self, $rev) = @_;
 215
 216     return unless $rev;
 217     return ($rev =~ /^([0-9a-fA-F]{40})$/);
 218 }
 219
 220 sub diff {
 221     my ($self, $project, @revs) = @_;
 222
 223     croak("Gitalist::Model::Git::diff needs a project and either one or two revisions")
 224         if scalar @revs < 1
 225         || scalar @revs > 2
 226         || any { !$self->valid_rev($_) } @revs;
 227
 228     my $output = $self->run_cmd_in($project, 'diff', @revs);
 229     return unless $output;
 230
 231     return $output;
 232 }
 233
 234 {
 235     my $formatter = DateTime::Format::Mail->new;
 236
 237     sub parse_rev_list {
 238         my ($self, $output) = @_;
 239         my @ret;
 240
 241         my @revs = split /\0/, $output;
 242
 243         for my $rev (split /\0/, $output) {
 244             for my $line (split /\n/, $rev, 6) {
 245                 chomp $line;
 246                 next unless $line;
 247
 248                 if ($self->valid_rev($line)) {
 249                     push @ret, {rev => $line};
 250                     next;
 251                 }
 252
 253                 if (my ($key, $value) = $line =~ /^(tree|parent)\s+(.*)$/) {
 254                     $ret[-1]->{$key} = $value;
 255                     next;
 256                 }
 257
 258                 if (my ($key, $value, $epoch, $tz) = $line =~ /^(author|committer)\s+(.*)\s+(\d+)\s+([+-]\d+)$/) {
 259                     $ret[-1]->{$key} = $value;
 260                     eval {
 261                         $ret[-1]->{ $key . "_datetime" } = DateTime->from_epoch(epoch => $epoch);
 262                         $ret[-1]->{ $key . "_datetime" }->set_time_zone($tz);
 263                         $ret[-1]->{ $key . "_datetime" }->set_formatter($formatter);
 264                     };
 265
 266                     if ($@) {
 267                         $ret[-1]->{ $key . "_datetime" } = "$epoch $tz";
 268                     }
 269
 270                     if (my ($name, $email) = $value =~ /^([^<]+)\s+<([^>]+)>$/) {
 271                         $ret[-1]->{ $key . "_name"  } = $name;
 272                         $ret[-1]->{ $key . "_email" } = $email;
 273                     }
 274                 }
 275
 276                 $line =~ s/^\n?\s{4}//;
 277                 $ret[-1]->{longmessage} = $line;
 278                 $ret[-1]->{message} = (split /\n/, $line, 2)[0];
 279             }
 280         }
 281
 282         return @ret;
 283     }
 284 }
 285
 286 sub list_revs {
 287     my ($self, $project, %args) = @_;
 288
 289     $args{rev} ||= $self->get_head_hash($project);
 290
 291     my $output = $self->run_cmd_in($project, 'rev-list',
 292             '--header',
 293             (defined $args{ count } ? "--max-count=$args{count}" : ()),
 294             (defined $args{ skip  } ? "--skip=$args{skip}"     : ()),
 295             $args{rev},
 296             '--',
 297             ($args{file} || ()),
 298     );
 299     return unless $output;
 300
 301     my @revs = $self->parse_rev_list($output);
 302
 303     return \@revs;
 304 }
 305
 306 sub rev_info {
 307     my ($self, $project, $rev) = @_;
 308
 309     return unless $self->valid_rev($rev);
 310
 311     return $self->list_revs($project, rev => $rev, count => 1);
 312 }
 313
 314 sub get_heads {
 315     my ($self, $project) = @_;
 316
 317     my $output = $self->run_cmd_in($project, qw/for-each-ref --sort=-committerdate /, '--format=%(objectname)%00%(refname)%00%(committer)', 'refs/heads');
 318     return unless $output;
 319
 320     my @ret;
 321     for my $line (split /\n/, $output) {
 322         my ($rev, $head, $commiter) = split /\0/, $line, 3;
 323         $head =~ s!^refs/heads/!!;
 324
 325         push @ret, { rev => $rev, name => $head };
 326
 327         #FIXME: That isn't the time I'm looking for..
 328         if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) {
 329             my $dt = DateTime->from_epoch(epoch => $epoch);
 330             $dt->set_time_zone($tz);
 331             $ret[-1]->{last_change} = $dt;
 332         }
 333     }
 334
 335     return \@ret;
 336 }
 337
 338 sub archive {
 339     my ($self, $project, $rev) = @_;
 340
 341     #FIXME: huge memory consuption
 342     #TODO: compression
 343     return $self->run_cmd_in($project, qw/archive --format=tar/, "--prefix=${project}/", $rev);
 344 }
 345
 346 ## from gitweb.pm
 347
 348 # checking HEAD file with -e is fragile if the repository was
 349 # initialized long time ago (i.e. symlink HEAD) and was pack-ref'ed
 350 # and then pruned.
 351 sub check_head_link {
 352         my ($dir) = @_;
 353         my $headfile = "$dir/HEAD";
 354         return ((-e $headfile) ||
 355                 (-l $headfile && readlink($headfile) =~ /^refs\/heads\//));
 356 }
 357
 358 sub check_export_ok {
 359         my ($dir) = @_;
 360         my($export_ok, $export_auth_hook) = @{Gitalist->config}{qw(export_ok export_auth_hook)};
 361         return (check_head_link($dir) &&
 362                 (!$export_ok || -e "$dir/$export_ok") &&
 363                 (!$export_auth_hook || $export_auth_hook->($dir)));
 364 }
 365
 366 sub projects {
 367         my($self, $filter) = @_;
 368         my @list;
 369
 370         $filter ||= '';
 371         $filter =~ s/\.git$//;
 372
 373         my $projects_list = Gitalist->config->{projectroot};
 374         if (-d $projects_list) {
 375                 # search in directory
 376                 my $dir = $projects_list . ($filter ? "/$filter" : '');
 377                 # remove the trailing "/"
 378                 $dir =~ s!/+$!!;
 379                 my $pfxlen = length("$dir");
 380                 my $pfxdepth = ($dir =~ tr!/!!);
 381
 382                 File::Find::find({
 383                         follow_fast => 1, # follow symbolic links
 384                         follow_skip => 2, # ignore duplicates
 385                         dangling_symlinks => 0, # ignore dangling symlinks, silently
 386                         wanted => sub {
 387                                 # skip project-list toplevel, if we get it.
 388                                 return if (m!^[/.]$!);
 389                                 # only directories can be git repositories
 390                                 return unless (-d $_);
 391                                 # don't traverse too deep (Find is super slow on os x)
 392                                 if (($File::Find::name =~ tr!/!!) - $pfxdepth > Gitalist->config->{project_maxdepth}) {
 393                                         $File::Find::prune = 1;
 394                                         return;
 395                                 }
 396
 397                                 my $subdir = substr($File::Find::name, $pfxlen + 1);
 398                                 # we check related file in $projectroot
 399                                 my $path = ($filter ? "$filter/" : '') . $subdir;
 400                                 if (check_export_ok("$projects_list/$path")) {
 401                                         push @list, { path => $path };
 402                                         $File::Find::prune = 1;
 403                                 }
 404                         },
 405                 }, "$dir");
 406
 407         } elsif (-f $projects_list) {
 408                 # read from file(url-encoded):
 409                 # 'git%2Fgit.git Linus+Torvalds'
 410                 # 'libs%2Fklibc%2Fklibc.git H.+Peter+Anvin'
 411                 # 'linux%2Fhotplug%2Fudev.git Greg+Kroah-Hartman'
 412                 my %paths;
 413                 open my ($fd), $projects_list or return;
 414         PROJECT:
 415                 while (my $line = <$fd>) {
 416                         chomp $line;
 417                         my ($path, $owner) = split ' ', $line;
 418                         $path = unescape($path);
 419                         $owner = unescape($owner);
 420                         if (!defined $path) {
 421                                 next;
 422                         }
 423                         if ($filter ne '') {
 424                                 # looking for forks;
 425                                 my $pfx = substr($path, 0, length($filter));
 426                                 if ($pfx ne $filter) {
 427                                         next PROJECT;
 428                                 }
 429                                 my $sfx = substr($path, length($filter));
 430                                 if ($sfx !~ /^\/.*\.git$/) {
 431                                         next PROJECT;
 432                                 }
 433                         }
 434                         if (check_export_ok("$projects_list/$path")) {
 435                                 my $pr = {
 436                                         path => $path,
 437                                         owner => to_utf8($owner),
 438                                 };
 439                                 push @list, $pr;
 440                                 (my $forks_path = $path) =~ s/\.git$//;
 441                                 $paths{$forks_path}++;
 442                         }
 443                 }
 444                 close $fd;
 445         }
 446         return @list;
 447 }
 448
 449 1;
 450
 451 __PACKAGE__->meta->make_immutable;