WIP of moving the project list to an action.

[catagits/Gitalist.git] / lib / Gitalist / Model / Git.pm

package Gitalist::Model::Git;

use Moose;
use namespace::autoclean;

BEGIN { extends 'Catalyst::Model' }

use DateTime;
use Path::Class;
use Carp qw/croak/;
use File::Find::Rule;
use DateTime::Format::Mail;
use File::Stat::ModeString;
use List::MoreUtils qw/any/;
use Scalar::Util qw/blessed/;

use Gitalist::Util qw(to_utf8);

# from gitweb.pm
use CGI::Util qw(unescape);

has git => (
	is      => 'ro',
	isa     => 'Str',
	lazy    => 1,
	default => sub {
		my $git;

		if (my $config_git = Gitalist->config->{git}) {
			$git = $config_git if -x $config_git;
		}
		else {
			require File::Which;
			$git = File::Which::which('git');
		}

		if (!$git) {
			die <<EOR
Could not find a git executable.
Please specify the which git executable to use in gitweb.yml
EOR
		}

		return $git;
	},
);

sub is_git_repo {
    my ($self, $dir) = @_;

    #FIXME: Only handles bare repos. Is that enough?
    return -f $dir->file('HEAD');
}

sub project_info {
    my ($self, $project) = @_;

    return {
        name => $project,
        $self->get_project_properties(
                $self->git_dir_from_project_name($project),
        ),
    };
}

sub get_project_properties {
    my ($self, $dir) = @_;
    my %props;

    eval {
        $props{description} = $dir->file('description')->slurp;
        chomp $props{description};
    };

    if ($props{description} =~ /^Unnamed repository;/) {
        delete $props{description};
    }

    $props{owner} = (getpwuid $dir->stat->uid)[6];

    my $output = $self->run_cmd_in($dir, qw{
            for-each-ref --format=%(committer)
            --sort=-committerdate --count=1 refs/heads
    });

    if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) {
        my $dt = DateTime->from_epoch(epoch => $epoch);
        $dt->set_time_zone($tz);
        $props{last_change} = $dt;
    }

    return %props;
}

sub list_projects {
    my ($self) = @_;

    my $base = dir(Gitalist->config->{repo_dir});

    my @ret;
    my $dh = $base->open;
    while (my $file = $dh->read) {
        next if $file =~ /^.{1,2}$/;

        my $obj = $base->subdir($file);
        next unless -d $obj;
        next unless $self->is_git_repo($obj);

        push @ret, {
            name => ($obj->dir_list)[-1],
            $self->get_project_properties($obj),
        };
    }

    return \@ret;
}

sub run_cmd {
    my ($self, @args) = @_;

    open my $fh, '-|', __PACKAGE__->git, @args
        or die "failed to run git command";
    binmode $fh, ':encoding(UTF-8)';

    my $output = do { local $/ = undef; <$fh> };
    close $fh;

    return $output;
}

sub run_cmd_in {
    my ($self, $project, @args) = @_;

    my $path;
    if (blessed($project) && $project->isa('Path::Class::Dir')) {
        $path = $project->stringify;
    }
    else {
        $path = $self->git_dir_from_project_name($project);
    }
    return $self->run_cmd('--git-dir' => $path, @args);
}

sub git_dir_from_project_name {
    my ($self, $project) = @_;

    return dir(Gitalist->config->{repo_dir})->subdir($project);
}

sub get_head_hash {
    my ($self, $project) = @_;

    my $output = $self->run_cmd_in($project, qw/rev-parse --verify HEAD/ );
    return unless defined $output;

    my ($head) = $output =~ /^([0-9a-fA-F]{40})$/;
    return $head;
}

sub list_tree {
    my ($self, $project, $rev) = @_;

    $rev ||= $self->get_head_hash($project);

    my $output = $self->run_cmd_in($project, qw/ls-tree -z/, $rev);
    return unless defined $output;

    my @ret;
    for my $line (split /\0/, $output) {
        my ($mode, $type, $object, $file) = split /\s+/, $line, 4;

        push @ret, {
            mode   => oct $mode,
            type   => $type,
            object => $object,
            file   => $file,
        };
    }

    return @ret;
}

sub get_object_mode_string {
    my ($self, $object) = @_;

    return unless $object && $object->{mode};
    return mode_to_string($object->{mode});
}

sub get_object_type {
    my ($self, $project, $object) = @_;

    my $output = $self->run_cmd_in($project, qw/cat-file -t/, $object);
    return unless $output;

    chomp $output;
    return $output;
}

sub cat_file {
    my ($self, $project, $object) = @_;

    my $type = $self->get_object_type($project, $object);
    die "object `$object' is not a file\n"
        if (!defined $type || $type ne 'blob');

    my $output = $self->run_cmd_in($project, qw/cat-file -p/, $object);
    return unless $output;

    return $output;
}

sub valid_rev {
    my ($self, $rev) = @_;

    return unless $rev;
    return ($rev =~ /^([0-9a-fA-F]{40})$/);
}

sub diff {
    my ($self, $project, @revs) = @_;

    croak("Gitalist::Model::Git::diff needs a project and either one or two revisions")
        if scalar @revs < 1
        || scalar @revs > 2
        || any { !$self->valid_rev($_) } @revs;

    my $output = $self->run_cmd_in($project, 'diff', @revs);
    return unless $output;

    return $output;
}

{
    my $formatter = DateTime::Format::Mail->new;

    sub parse_rev_list {
        my ($self, $output) = @_;
        my @ret;

        my @revs = split /\0/, $output;

        for my $rev (split /\0/, $output) {
            for my $line (split /\n/, $rev, 6) {
                chomp $line;
                next unless $line;

                if ($self->valid_rev($line)) {
                    push @ret, {rev => $line};
                    next;
                }

                if (my ($key, $value) = $line =~ /^(tree|parent)\s+(.*)$/) {
                    $ret[-1]->{$key} = $value;
                    next;
                }

                if (my ($key, $value, $epoch, $tz) = $line =~ /^(author|committer)\s+(.*)\s+(\d+)\s+([+-]\d+)$/) {
                    $ret[-1]->{$key} = $value;
                    eval {
                        $ret[-1]->{ $key . "_datetime" } = DateTime->from_epoch(epoch => $epoch);
                        $ret[-1]->{ $key . "_datetime" }->set_time_zone($tz);
                        $ret[-1]->{ $key . "_datetime" }->set_formatter($formatter);
                    };

                    if ($@) {
                        $ret[-1]->{ $key . "_datetime" } = "$epoch $tz";
                    }

                    if (my ($name, $email) = $value =~ /^([^<]+)\s+<([^>]+)>$/) {
                        $ret[-1]->{ $key . "_name"  } = $name;
                        $ret[-1]->{ $key . "_email" } = $email;
                    }
                }

                $line =~ s/^\n?\s{4}//;
                $ret[-1]->{longmessage} = $line;
                $ret[-1]->{message} = (split /\n/, $line, 2)[0];
            }
        }

        return @ret;
    }
}

sub list_revs {
    my ($self, $project, %args) = @_;

    $args{rev} ||= $self->get_head_hash($project);

    my $output = $self->run_cmd_in($project, 'rev-list',
            '--header',
            (defined $args{ count } ? "--max-count=$args{count}" : ()),
            (defined $args{ skip  } ? "--skip=$args{skip}"     : ()),
            $args{rev},
            '--',
            ($args{file} || ()),
    );
    return unless $output;

    my @revs = $self->parse_rev_list($output);

    return \@revs;
}

sub rev_info {
    my ($self, $project, $rev) = @_;

    return unless $self->valid_rev($rev);

    return $self->list_revs($project, rev => $rev, count => 1);
}

sub get_heads {
    my ($self, $project) = @_;

    my $output = $self->run_cmd_in($project, qw/for-each-ref --sort=-committerdate /, '--format=%(objectname)%00%(refname)%00%(committer)', 'refs/heads');
    return unless $output;

    my @ret;
    for my $line (split /\n/, $output) {
        my ($rev, $head, $commiter) = split /\0/, $line, 3;
        $head =~ s!^refs/heads/!!;

        push @ret, { rev => $rev, name => $head };

        #FIXME: That isn't the time I'm looking for..
        if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) {
            my $dt = DateTime->from_epoch(epoch => $epoch);
            $dt->set_time_zone($tz);
            $ret[-1]->{last_change} = $dt;
        }
    }

    return \@ret;
}

sub archive {
    my ($self, $project, $rev) = @_;

    #FIXME: huge memory consuption
    #TODO: compression
    return $self->run_cmd_in($project, qw/archive --format=tar/, "--prefix=${project}/", $rev);
}

## from gitweb.pm

# checking HEAD file with -e is fragile if the repository was
# initialized long time ago (i.e. symlink HEAD) and was pack-ref'ed
# and then pruned.
sub check_head_link {
	my ($dir) = @_;
	my $headfile = "$dir/HEAD";
	return ((-e $headfile) ||
		(-l $headfile && readlink($headfile) =~ /^refs\/heads\//));
}

sub check_export_ok {
	my ($dir) = @_;
	my($export_ok, $export_auth_hook) = @{Gitalist->config}{qw(export_ok export_auth_hook)};
	return (check_head_link($dir) &&
		(!$export_ok || -e "$dir/$export_ok") &&
		(!$export_auth_hook || $export_auth_hook->($dir)));
}

sub projects {
	my($self, $filter) = @_;
	my @list;

	$filter ||= '';
	$filter =~ s/\.git$//;

	my $projects_list = Gitalist->config->{projectroot};
	if (-d $projects_list) {
		# search in directory
		my $dir = $projects_list . ($filter ? "/$filter" : '');
		# remove the trailing "/"
		$dir =~ s!/+$!!;
		my $pfxlen = length("$dir");
		my $pfxdepth = ($dir =~ tr!/!!);

		File::Find::find({
			follow_fast => 1, # follow symbolic links
			follow_skip => 2, # ignore duplicates
			dangling_symlinks => 0, # ignore dangling symlinks, silently
			wanted => sub {
				# skip project-list toplevel, if we get it.
				return if (m!^[/.]$!);
				# only directories can be git repositories
				return unless (-d $_);
				# don't traverse too deep (Find is super slow on os x)
				if (($File::Find::name =~ tr!/!!) - $pfxdepth > Gitalist->config->{project_maxdepth}) {
					$File::Find::prune = 1;
					return;
				}

				my $subdir = substr($File::Find::name, $pfxlen + 1);
				# we check related file in $projectroot
				my $path = ($filter ? "$filter/" : '') . $subdir;
				if (check_export_ok("$projects_list/$path")) {
					push @list, { path => $path };
					$File::Find::prune = 1;
				}
			},
		}, "$dir");

	} elsif (-f $projects_list) {
		# read from file(url-encoded):
		# 'git%2Fgit.git Linus+Torvalds'
		# 'libs%2Fklibc%2Fklibc.git H.+Peter+Anvin'
		# 'linux%2Fhotplug%2Fudev.git Greg+Kroah-Hartman'
		my %paths;
		open my ($fd), $projects_list or return;
	PROJECT:
		while (my $line = <$fd>) {
			chomp $line;
			my ($path, $owner) = split ' ', $line;
			$path = unescape($path);
			$owner = unescape($owner);
			if (!defined $path) {
				next;
			}
			if ($filter ne '') {
				# looking for forks;
				my $pfx = substr($path, 0, length($filter));
				if ($pfx ne $filter) {
					next PROJECT;
				}
				my $sfx = substr($path, length($filter));
				if ($sfx !~ /^\/.*\.git$/) {
					next PROJECT;
				}
			}
			if (check_export_ok("$projects_list/$path")) {
				my $pr = {
					path => $path,
					owner => to_utf8($owner),
				};
				push @list, $pr;
				(my $forks_path = $path) =~ s/\.git$//;
				$paths{$forks_path}++;
			}
		}
		close $fd;
	}
	return @list;
}

1;

__PACKAGE__->meta->make_immutable;