lib/Ssoma/Git.pm

   1 # Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> and all contributors
   2 # License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt)
   3 #
   4 # Note: some trivial code here stolen from git-svn + Perl modules
   5 # distributed with git.  I wrote these long ago and retain my copyright
   6 # to it, so I'm within my right to relicense as AGPLv3+.  The original
   7 # git versions remain GPLv2.
   8 #
   9 # Not using Git.pm and friends directly because some git installations may use
  10 # a different Perl than this (and I might end up rewriting this entirely
  11 # in C at a later time...)
  12 package Ssoma::Git;
  13 use strict;
  14 use warnings;
  15 use File::Path qw/mkpath/;
  16 use IO::Handle;
  17 use Fcntl;
  18 use File::FcntlLock;
  19 use Email::Simple;
  20 use Digest::SHA qw/sha1_hex/;
  21
  22 # Future versions of Ssoma will always be able to handle this version, at least
  23 our $REPO_VERSION = 1;
  24
  25 sub new {
  26         my ($class, $git_dir) = @_;
  27         bless {
  28                 git_dir => $git_dir,
  29                 index => "$git_dir/ssoma.index",
  30         }, $class;
  31 }
  32
  33 # initialize a git repository
  34 sub init_db {
  35         my ($self, @opts) = @_;
  36
  37         my @cmd = (qw(git init --bare), @opts);
  38         push @cmd, $self->{git_dir};
  39
  40         system(@cmd) == 0 or die join(' ', @cmd)." failed: $?\n";
  41
  42         $self->tmp_git_do(sub {
  43                 @cmd = (qw(git config ssoma.repoversion), $REPO_VERSION);
  44                 system(@cmd) == 0 or die "command: ". join(' ', @cmd) . ": $?\n";
  45         });
  46 }
  47
  48 sub lockfile { $_[0]->{git_dir} . "/ssoma.lock" }
  49
  50 sub sync_do {
  51         my ($self, $sub) = @_;
  52
  53         my $fs = File::FcntlLock->new;
  54         $fs->l_type(F_WRLCK);
  55         $fs->l_type(SEEK_CUR);
  56         $fs->l_start(0);
  57         $fs->l_len(0);
  58
  59         my $path = $self->lockfile;
  60         my $lock;
  61
  62         # we must not race here because this is concurrent:
  63         sysopen($lock, $path, O_WRONLY) or
  64                 sysopen($lock, $path, O_CREAT|O_EXCL|O_WRONLY) or
  65                 sysopen($lock, $path, O_WRONLY) or
  66                 die "failed to open lock $path: $!\n";
  67
  68         # wait for other processes to be done
  69         $fs->lock($lock, F_SETLKW) or die "lock failed: " . $fs->error . "\n";
  70
  71         # run the sub!
  72         my @ret = eval { &$sub };
  73         my $err = $@;
  74
  75         # these would happen anyways, but be explicit so we can detect errors
  76         $fs->lock($lock, F_UNLCK) or die "unlock failed: " . $fs->error . "\n";
  77         close $lock or die "close lockfile($path) failed: $!\n";
  78
  79         die $err if $err;
  80
  81         wantarray ? @ret : $ret[0];
  82 }
  83
  84 # perform sub with the given GIT_DIR
  85 sub tmp_git_do {
  86         my ($self, $sub) = @_;
  87         local $ENV{GIT_DIR} = $self->{git_dir};
  88         &$sub;
  89 }
  90
  91 # perform sub with a temporary index
  92 sub tmp_index_do {
  93         my ($self, $sub) = @_;
  94         local $ENV{GIT_INDEX_FILE} = $self->{index};
  95
  96         my ($dir, $base) = ($self->{index} =~ m#^(.*?)/?([^/]+)$#);
  97         mkpath([$dir]) unless -d $dir;
  98         -d $dir or die "$dir creation failed $!\n";
  99         &$sub;
 100 }
 101
 102 # bidirectional pipe, output would be SHA-1 hexdigest
 103 sub bidi_sha1 {
 104         my ($self, @cmd) = @_;
 105         my $sub = pop @cmd;
 106         my $cmd = join(' ', @cmd);
 107         my ($in_0, $in_1, $out_0, $out_1);
 108
 109         pipe($in_0, $in_1) or die "pipe failed: $!\n";
 110         pipe($out_0, $out_1) or die "pipe failed: $!\n";
 111
 112         my $pid = fork;
 113         defined $pid or die "fork failed: $!\n";
 114
 115         if ($pid == 0) {
 116                 open STDIN, '<&', $in_0 or die "redirect stdin failed: $!\n";
 117                 open STDOUT, '>&', $out_1 or die "redirect stdout failed: $!\n";
 118                 exec @cmd;
 119                 die "exec($cmd) failed: $!\n";
 120         }
 121
 122         close $in_0 or die "close in_0 failed: $!\n";
 123         close $out_1 or die "close out_1 failed: $!\n";
 124         $sub->($in_1);
 125         close $in_1 or die "close in_1 failed: $!\n";
 126         my $sha1 = <$out_0>;
 127         close $out_0 or die "close out_0 failed: $!\n";
 128         waitpid($pid, 0) or die "waitpid $pid failed: $!\n";
 129         $? == 0 or die "$cmd failed: $?\n";
 130         chomp $sha1;
 131         $sha1 =~ /\A[a-f0-9]{40}\z/i or die "not a SHA-1: $sha1\n";
 132         $sha1;
 133 }
 134
 135 # run a command described by str and return the SHA-1 hexdigest output
 136 sub qx_sha1 {
 137         my ($self, $str) = @_;
 138         my $sha1 = `$str`;
 139
 140         die "$str failed: $?\n" if $?;
 141         chomp $sha1;
 142         $sha1 =~ /\A[a-f0-9]{40}\z/i or
 143                 die "not a SHA-1 hexdigest from: $str\n";
 144         $sha1;
 145 }
 146
 147 # returns a blob identifier the new message
 148 sub simple_to_blob {
 149         my ($self, $simple) = @_;
 150         $self->bidi_sha1(qw/git hash-object -w --stdin/, sub {
 151                 my ($io) = @_;
 152                 print $io $simple->as_string or die "print failed: $!\n";
 153         });
 154 }
 155
 156 # converts the given object name to an Email::Simple object
 157 sub blob_to_simple {
 158         my ($self, $obj) = @_;
 159         Email::Simple->new($self->cat_blob($obj));
 160 }
 161
 162 # returns key-value pairs of config directives in a hash
 163 sub config_list {
 164         my ($self, $file) = @_;
 165
 166         local $ENV{GIT_CONFIG} = $file;
 167
 168         my @cfg = `git config -l`;
 169         $? == 0 or die "git config -l failed: $?\n";
 170         chomp @cfg;
 171         my %rv = map { split(/=/, $_, 2) } @cfg;
 172         \%rv;
 173 }
 174
 175 # used to hash the relevant portions of a message when there are conflicts
 176 sub hash_simple2 {
 177         my ($self, $simple) = @_;
 178         my $dig = Digest::SHA->new("SHA-1");
 179         $dig->add($simple->header("Subject"));
 180         $dig->add($simple->body);
 181         $dig->hexdigest;
 182 }
 183
 184 # we currently only compare messages for equality based on
 185 # Message-ID, Subject: header and body, nothing else.
 186 # both args are Email::Simple objects
 187 sub simple_eq {
 188         my ($self, $cur, $new) = @_;
 189
 190         (($cur->header("Subject") eq $new->header("Subject")) &&
 191          ($cur->body eq $new->body));
 192 }
 193
 194 # kills leading/trailing space in-place
 195 sub stripws {
 196         $_[0] =~ s/\A\s*//;
 197         $_[0] =~ s/\s*\z//;
 198 }
 199
 200 sub mid2path {
 201         my ($self, $message_id) = @_;
 202         stripws($message_id);
 203         my $hex = sha1_hex($message_id);
 204         $hex =~ /\A([a-f0-9]{2})([a-f0-9]{38})\z/i or
 205                         die "BUG: not a SHA-1 hex: $hex";
 206         "$1/$2";
 207 }
 208
 209 sub cat_blob {
 210         my ($self, $blob_id) = @_;
 211         my $cmd = "git cat-file blob $blob_id";
 212         my $str = `$cmd`;
 213         die "$cmd failed: $?\n" if $?;
 214         $str;
 215 }
 216
 217 sub type {
 218         my ($self, $obj) = @_;
 219         my $cmd = "git cat-file -t $obj";
 220         my $str = `$cmd`;
 221         die "$cmd failed: $?\n" if $?;
 222         chomp $str;
 223         $str;
 224 }
 225
 226 # only used for conflict resolution
 227 sub each_in_tree {
 228         my ($self, $obj, $sub) = @_;
 229         my $cmd = "git ls-tree $obj";
 230         my @tree = `$cmd`;
 231         $? == 0 or die "$cmd failed: $!\n";
 232         my $x40 = '[a-f0-9]{40}';
 233         foreach my $line (@tree) {
 234                 if ($line =~ m!\A100644 blob ($x40)\t($x40)$!o) {
 235                         my ($blob_id, $path) = ($1, $2);
 236                         $sub->($blob_id, $path);
 237                 } else {
 238                         warn "unexpected: bad line from $cmd:\n$line";
 239                 }
 240         }
 241 }
 242
 243 sub commit_index {
 244         my ($self, $gii, $need_parent, $ref, $message) = @_;
 245
 246         # this is basically what git commit(1) does,
 247         # but we use git plumbing, not porcelain
 248         $gii->done;
 249         my $tree = $self->qx_sha1("git write-tree");
 250
 251         # can't rely on qx_sha1 since we initial commit may not have a parent
 252         my $cmd = "git rev-parse $ref^0";
 253         my $parent;
 254         if ($need_parent) {
 255                 $parent = $self->qx_sha1($cmd);
 256         } else {
 257                 $parent = eval { $self->qx_sha1("$cmd 2>/dev/null") };
 258                 if (defined $parent && $parent !~ /\A[a-f0-9]{40}\z/) {
 259                         die "$cmd returned bad SHA-1: $parent\n";
 260                 }
 261         }
 262
 263         # make the commit
 264         my @cmd = (qw/git commit-tree -m/, $message);
 265         push @cmd, '-p', $parent if $parent;
 266         push @cmd, $tree;
 267         my $commit = $self->qx_sha1(join(' ', @cmd));
 268
 269         # update the ref
 270         @cmd = (qw/git update-ref/, $ref, $commit);
 271         push @cmd, $parent if $parent; # verification
 272         system(@cmd) == 0 or die "command: ". join(' ', @cmd) . ": $?\n";
 273
 274         # gc if needed
 275         @cmd = qw/git gc --auto/;
 276         system(@cmd) == 0 or die "command: ". join(' ', @cmd) . ": $?\n";
 277 }
 278
 279 1;