git-remote-gpg

   1 #!/usr/bin/perl
   2 our $VERSION = '2014.04.29';
   3 # License
   4         # This file is a git-remote-helpers(1) to use a gpg(1)
   5         # as a cryptographic layer below git(1)'s objects.
   6         # Copyright (C) 2014  Julien Moutinho
   7         #
   8         # This program is free software: you can redistribute it and/or modify
   9         # it under the terms of the GNU General Public License as published
  10         # by the Free Software Foundation, either version 3 of the License,
  11         # or any later version.
  12         #
  13         # This program is distributed in the hope that it will be useful,
  14         # but WITHOUT ANY WARRANTY; without even the implied warranty
  15         # of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  16         # See the GNU General Public License for more details.
  17         #
  18         # You should have received a copy of the GNU General Public License
  19         # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20 # Dependencies
  21         use strict;
  22         use warnings FATAL => qw(all);
  23         use Carp;
  24         use Cwd;
  25         use File::Basename;
  26         use File::Copy;
  27         use File::Path;
  28         use File::Spec::Functions qw(:ALL);
  29         use File::Temp;
  30         use Getopt::Long;
  31         use IPC::Run;
  32                 # NOTE: to debug: IPCRUNDEBUG=basic|data|details|gory
  33         use IO::Handle;
  34         use JSON;
  35         use POSIX qw(WNOHANG);
  36         use URI;
  37
  38         require Pod::Usage;
  39         require Data::Dumper;
  40 # Trace utilities
  41         sub trace (@) {
  42                 foreach my $msg (@_) {
  43                         print STDERR $msg
  44                                 if defined $msg;
  45                  }
  46          }
  47         sub debug (@) {
  48                 my $call = (caller(1))[3];
  49                 if ($ENV{TRACE}) {
  50                         trace
  51                          ( "\e[35mDEBUG\e[m"
  52                          , "\e[30m\e[1m.", join('.', $call."\e[m")
  53                          , " ", (map {
  54                                 ref $_ eq 'CODE'
  55                                  ? $_->()
  56                                  : Data::Dumper::Dumper($_)
  57                                 } @_)
  58                          );
  59                  }
  60                 return 1;
  61          }
  62         sub info (@) {
  63                 my $call = (caller(1))[3];
  64                 trace
  65                  ( "\e[32mINFO\e[m"
  66                  , "\e[30m\e[1m.", join('.', $call."\e[m")
  67                  , " ", (ref $_ eq 'CODE'?(join("\n      ", $_->()), "\n"):(@_, "\n"))
  68                  );
  69          }
  70         sub warning (@) {
  71                 local $Carp::CarpLevel = 1;
  72                 carp("\e[33mWARNING\e[m ", @_, "\n\t");
  73          }
  74         sub error (@) {
  75                 local $Carp::CarpLevel = 1;
  76                 croak("\e[31mERROR\e[m ", @_, "\n\t");
  77          }
  78 # System utilities
  79         sub rm (@) {
  80                 foreach my $file (@_) {
  81                         debug(sub{"file=$file\n"});
  82                         if (-e $file) {
  83                                 unlink($file)
  84                                         or error("rm $file");
  85                          }
  86                  }
  87          }
  88         sub mkdir (@) {
  89                 foreach my $dir (@_) {
  90                         debug(sub{"dir=$dir\n"});
  91                         File::Path::make_path($dir, {verbose=>0, error => \my $error});
  92                         if (@$error) {
  93                                 for my $diag (@$error) {
  94                                         my ($dir, $message) = %$diag;
  95                                         error("dir=$dir: $message");
  96                                  }
  97                          }
  98                  }
  99          }
 100 # grg crypto
 101         sub grg_rand ($$) {
 102                 my ($ctx, $size) = @_;
 103                 local $_;
 104                 IPC::Run::run([@{$ctx->{config}->{gpg}}
 105                  , '--armor', '--gen-rand', '1', $size]
 106                  , '>', \$_)
 107                         or error("failed to get random bits");
 108                 chomp;
 109                 return $_;
 110          }
 111         sub grg_hash ($$;$) {
 112                 my ($ctx, $algo, $run) = @_;
 113                 $run = sub {return @_} unless defined $run;
 114                 my $hash;
 115                 IPC::Run::run($run->([@{$ctx->{config}->{gpg}}
 116                  , '--with-colons', '--print-md', $algo]
 117                  , '>', \$hash))
 118                         or error("failed to hash data");
 119                 return ((split(':', $hash))[2]);
 120          }
 121         sub gpg_fingerprint($$$) {
 122                 my ($ctx, $id, $caps_needed) = @_;
 123                 my ($output);
 124                 my %h = ();
 125                 if (IPC::Run::run([@{$ctx->{config}->{gpg}}
 126                  , '--fixed-list-mode', '--with-colons', '--with-fingerprint', '--list-keys', $id]
 127                  , '>', \$output)) {
 128                         my @lines = split(/\n/,$output);
 129                         while (my $line = shift @lines) {
 130                                 if (my ($longkeyid, $caps) = $line =~ m/^pub:[^:]*:[^:]*:[^:]*:([^:]*):[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:([^:]+):.*$/) {
 131                                         my $skip = 0;
 132                                         foreach my $cap (@$caps_needed) {
 133                                                 if (not ($caps =~ m/$cap/)) {
 134                                                         warning("skipping key 0x$longkeyid which has not usable capability: $cap, but matches: `$id'");
 135                                                         $skip = 1;
 136                                                  }
 137                                          }
 138                                         if (not $skip) {
 139                                                 my $fpr = undef;
 140                                                 my $uid = undef;
 141                                                 while ((not defined $fpr or not defined $uid)
 142                                                  and $line = shift @lines) {
 143                                                         (not defined $fpr and (($fpr) = $line =~ m/^fpr:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:([0-9A-F]+):.*$/)) or
 144                                                         (not defined $uid and (($uid) = $line =~ m/^uid:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:([^:]+):.*$/)) or
 145                                                         1;
 146                                                  }
 147                                                 error("unable to extract fingerprint and user ID")
 148                                                         unless defined $fpr
 149                                                         and    defined $uid;
 150                                                 $h{$fpr} = $uid;
 151                                          }
 152                                  }
 153                          }
 154                  }
 155                 error("unable to find any OpenPGP key with usable capability: ".join('', @$caps_needed)." for: `$id'")
 156                         unless scalar(%h) gt 0;
 157                 debug(sub{"$id -> "}, \%h);
 158                 return %h;
 159          }
 160         sub grg_encrypt_symmetric ($$$;$) {
 161                 my ($ctx, $clear, $key, $run) = @_;
 162                 $run = sub {return @_} unless defined $run;
 163                 IPC::Run::run($run->([@{$ctx->{config}->{gpg}}
 164                  , '--batch', '--yes'
 165                  , '--compress-algo', 'none'
 166                  , '--force-mdc'
 167                  , '--passphrase-fd', '3'
 168                  , '--s2k-mode', '1'
 169                  , '--trust-model', 'always'
 170                  , '--symmetric']
 171                  , '<', \$clear, '3<', \$key))
 172                         or error("failed to encrypt symmetrically data");
 173          }
 174         sub grg_decrypt_symmetric ($$$;$) {
 175                 my ($ctx, $key, $run) = @_;
 176                 $run = sub {return @_} unless defined $run;
 177                 IPC::Run::run($run->([@{$ctx->{config}->{gpg}}
 178                  , '--batch', '--no-default-keyring', '--keyring', '/dev/null', '--secret-keyring', '/dev/null'
 179                  , '--passphrase-fd', '3', '--quiet', '--decrypt']
 180                  , '3<', \$key))
 181                         or error("failed to decrypt symmetrically data");
 182          }
 183         sub grg_encrypt_asymmetric ($$;$) {
 184                 my ($ctx, $clear, $run) = @_;
 185                 $run = sub {return @_} unless defined $run;
 186                 my @recipients =
 187                  ( (map { ('--recipient', '0x'.$_) } (keys %{$ctx->{config}->{keys}}))
 188                  , (map { ('--hidden-recipient', '0x'.$_) } (keys %{$ctx->{config}->{'hidden-keys'}})) );
 189                 @recipients = ('--default-recipient-self')
 190                         if @recipients == 0;
 191                 IPC::Run::run($run->([@{$ctx->{config}->{gpg}}
 192                  , '--batch', '--yes'
 193                  , '--compress-algo', 'none'
 194                  , '--trust-model', 'always'
 195                  , '--sign', '--encrypt'
 196                  , ($ctx->{config}->{signingkey}->{fpr} ? ('--local-user', $ctx->{config}->{signingkey}->{fpr}) : ())
 197                  , @recipients ]
 198                  , '<', \$clear))
 199                         or error("failed to encrypt asymmetrically data");
 200          }
 201         sub grg_decrypt_asymmetric ($$;$) {
 202                 my ($ctx, $run) = @_;
 203                 my ($clear, $status);
 204                 $run = sub {return @_} unless defined $run;
 205                 IPC::Run::run($run->([@{$ctx->{config}->{gpg}}
 206                  , '--batch', '--no-default-keyring',
 207                  , '--status-fd', '3', '--quiet', '--decrypt']
 208                  , '>', \$clear, '3>', \$status))
 209                         or error("failed to decrypt asymmetrically data");
 210                 debug(sub{"status=\n$status"});
 211                 my @lines = split(/\n/,$status);
 212                 my ($enc_to, $goodsig, $validsig, $validpub, $goodmdc);
 213                 foreach my $line (@lines) {
 214                         (not defined $enc_to and (($enc_to)   = $line =~ m/^\[GNUPG:\] ENC_TO ([0-9A-F]+).*$/)) or
 215                         (not defined $goodsig and (($goodsig) = $line =~ m/^\[GNUPG:\] GOODSIG ([0-9A-F]+).*$/)) or
 216                         (not defined $goodmdc and (($goodmdc) = $line =~ m/^\[GNUPG:\] (GOODMDC)$/)) or
 217                         (not defined $validsig and not defined $validpub and (($validsig, $validpub)
 218                                  = $line =~ m/^\[GNUPG:\] VALIDSIG ([0-9A-F]+) [^ ]+ [^ ]+ [^ ]+ [^ ]+ [^ ]+ [^ ]+ [^ ]+ [^ ]+ ([0-9A-F]+).*$/)) or
 219                         1;
 220                  }
 221                 error("data expected to be encrypted")
 222                         unless $enc_to;
 223                 debug(sub{"enc_to=$enc_to\n"});
 224                 error("data expected to be signed")
 225                         unless $goodsig;
 226                 debug(sub{"goodsig=$goodsig\n"});
 227                 error("modification detection code incorrect")
 228                         unless $goodmdc;
 229                 debug(sub{"good_mdc=$goodmdc\n"});
 230                 error("data signature invalid")
 231                         unless $validsig and $validpub;
 232                 debug(sub{"validsig=$validsig\n"});
 233                 debug(sub{"validpub=$validpub\n"});
 234                 error("data signature refused")
 235                         unless exists $ctx->{config}->{keys}->{$validpub}
 236                         or exists $ctx->{config}->{'hidden-keys'}->{$validpub};
 237                 debug(sub{"accepted:$validpub\n"});
 238                 return $clear;
 239          }
 240 # grg remote I/O
 241         sub grg_remote_fetch_file ($) {
 242                 my ($ctx) = @_;
 243                 # NOTE: avoid File::Copy::copy().
 244                 while (my ($file, undef) = each %{$ctx->{remote}->{fetch}}) {
 245                         my $path = File::Spec->catfile($ctx->{remote}->{uri}->file, $file);
 246                         if (-r $path) {
 247                                 my $h = $ctx->{remote}->{fetch}->{$file};
 248                                 $h->{path}     = $path;
 249                                 $h->{preserve} = 1;
 250                          }
 251                         else { return 0; }
 252                  }
 253                 return 1;
 254          }
 255         sub grg_remote_fetch_rsync ($) {
 256                 my ($ctx) = @_;
 257                 my $uri  = $ctx->{remote}->{uri}->clone;
 258                 my @src;
 259                 if ($uri->opaque =~ m{^//}) {
 260                         $uri->fragment(undef);
 261                         $uri->query(undef);
 262                         @src = map { $uri->path($_); $uri->as_string; }
 263                          (keys %{$ctx->{remote}->{fetch}});
 264                  }
 265                 else {
 266                         my ($authority, $path, $fragment)
 267                          = $uri->as_string =~ m|^rsync:(?:([^/#:]+):)?([^?#]*)(?:#(.*))?$|;
 268                         @src = map { "$authority:$path/$_" }
 269                          (keys %{$ctx->{remote}->{fetch}});
 270                  }
 271                 IPC::Run::run([@{$ctx->{config}->{rsync}}
 272                  , '-i', '--ignore-times', '--inplace', '--progress'
 273                  , @src
 274                  , $ctx->{'dir-cache'}.'/']
 275                  , '>&2')
 276          }
 277         sub grg_remote_fetch_sftp ($) {
 278                 my ($ctx) = @_;
 279                 IPC::Run::run([@{$ctx->{config}->{curl}}
 280                  , '--show-error'
 281                  , '--output', File::Spec->catfile($ctx->{'dir-cache'}, '#1')
 282                  , $ctx->{remote}->{uri}->as_string.'/'.'{'.join(',', (keys %{$ctx->{remote}->{fetch}})).'}' ]
 283                  , '>&2')
 284          }
 285         sub grg_remote_fetch ($$) {
 286                 my ($ctx, $files) = @_;
 287                 debug(sub{'files='}, $files);
 288                 my $scheme = $ctx->{remote}->{uri}->scheme;
 289                 $ctx->{remote}->{fetch}
 290                  = {map { $_ =>
 291                          { path => File::Spec->catfile($ctx->{'dir-cache'}, $_)
 292                          , preserve => 0 }
 293                  } @$files};
 294                 my $fct =
 295                  { file  => \&grg_remote_fetch_file
 296                  , rsync => \&grg_remote_fetch_rsync
 297                  , sftp  => \&grg_remote_fetch_sftp
 298                  }->{$scheme};
 299                 error("URL scheme not supported: `$scheme'")
 300                         unless $fct;
 301                 $fct->($ctx)
 302                         or $ctx->{remote}->{fetch} = {};
 303                 return $ctx->{remote}->{fetch};
 304          }
 305         sub grg_remote_init_file ($) {
 306                 my ($ctx) = @_;
 307                 my $dst = $ctx->{remote}->{uri}->file;
 308                 &mkdir($dst);
 309                 return 1;
 310          }
 311         sub grg_remote_init_rsync ($) {
 312                 my ($ctx) = @_;
 313                 my $tmp = File::Temp->tempdir('grg_rsync_XXXXXXXX', CLEANUP => 1);
 314                 my $uri = $ctx->{remote}->{uri}->clone;
 315                 my ($path, $dst);
 316                 if ($uri->opaque =~ m{^//}) {
 317                         $uri->fragment(undef);
 318                         $uri->query(undef);
 319                         $path = $uri->path;
 320                         $dst = $uri->as_string;
 321                  }
 322                 else {
 323                         my ($authority, $fragment);
 324                         ($authority, $path, $fragment)
 325                          = $uri->as_string =~ m|^rsync:(?:([^/#:]+):)?([^?#]*)(?:#(.*))?$|;
 326                         $dst = "$authority:";
 327                  }
 328                 &mkdir(File::Spec->catdir($tmp, $path));
 329                 IPC::Run::run([@{$ctx->{config}->{rsync}}
 330                  , '-i', '--recursive', '--relative'
 331                  , '--exclude=*', '.'
 332                  , $dst]
 333                  , '>&2'
 334                  , init => sub { chdir $tmp or die $!; })
 335          }
 336         sub grg_remote_init_sftp ($) {
 337                 my ($ctx) = @_;
 338                 my $uri  = $ctx->{remote}->{uri}->clone;
 339                 my ($path) = $uri->path =~ m|^/?(.*)$|;
 340                 $uri->fragment(undef);
 341                 $uri->path(undef);
 342                 $uri->query(undef);
 343                 IPC::Run::run([@{$ctx->{config}->{curl}}
 344                  , '--show-error', '--ftp-create-dirs'
 345                  , '-Q', "+mkdir ".$path
 346                  , $uri->as_string]
 347                  , '>&2')
 348          }
 349         sub grg_remote_init ($) {
 350                 my ($ctx) = @_;
 351                 my $scheme = $ctx->{remote}->{uri}->scheme;
 352                 my $fct =
 353                  { file  => \&grg_remote_init_file
 354                  , rsync => \&grg_remote_init_rsync
 355                  , sftp  => \&grg_remote_init_sftp
 356                  }->{$scheme};
 357                 error("URL scheme not supported: `$scheme'")
 358                         unless $fct;
 359                 $fct->($ctx)
 360                         or error("remote init failed");
 361                 return;
 362          }
 363         sub grg_remote_push_file ($) {
 364                 my ($ctx) = @_;
 365                 my $ok = 1;
 366                 foreach my $file (@{$ctx->{remote}->{push}}) {
 367                         my $src = File::Spec->catfile($ctx->{'dir-cache'}, $file);
 368                         my $dst = File::Spec->catfile($ctx->{remote}->{uri}->file, $file);
 369                         debug(sub{"File::Copy::move('$src', '$dst')\n"});
 370                         if (not File::Copy::move($src, $dst)) {
 371                                 $ok = 0;
 372                                 last;
 373                          }
 374                  }
 375                 return $ok;
 376          }
 377         sub grg_remote_push_rsync ($) {
 378                 my ($ctx) = @_;
 379                 my $uri = $ctx->{remote}->{uri}->clone;
 380                 $uri->fragment(undef);
 381                 $uri->query(undef);
 382                 my ($path, $dst);
 383                 if ($uri->opaque =~ m{^//}) {
 384                         $uri->fragment(undef);
 385                         $uri->query(undef);
 386                         $dst = $uri->as_string;
 387                  }
 388                 else {
 389                         my ($authority, $path, $fragment)
 390                          = $uri->as_string =~ m|^rsync:(?:([^/#:]+):)?([^?#]*)(?:#(.*))?$|;
 391                         $dst = "$authority:$path/";
 392                  }
 393                 IPC::Run::run([@{$ctx->{config}->{rsync}}
 394                  , '-i', '--relative'
 395                  , (@{$ctx->{remote}->{push}})
 396                  , $dst]
 397                  , '>&2'
 398                  , init => sub { chdir $ctx->{'dir-cache'} or die $!; });
 399          }
 400         sub grg_remote_push_sftp ($) {
 401                 my ($ctx) = @_;
 402                 my $uri = $ctx->{remote}->{uri}->clone;
 403                 $uri->fragment(undef);
 404                 $uri->query(undef);
 405                 IPC::Run::run([@{$ctx->{config}->{curl}}
 406                  , '--show-error', '--ftp-create-dirs', '--upload-file'
 407                  , File::Spec->catfile($ctx->{'dir-cache'},'{'.join(',', @{$ctx->{remote}->{push}}).'}')
 408                  , $uri->as_string.'/']
 409                  , '>&2')
 410          }
 411         sub grg_remote_push ($) {
 412                 my ($ctx) = @_;
 413                 my $scheme = $ctx->{remote}->{uri}->scheme;
 414                 grg_remote_init($ctx)
 415                         unless $ctx->{remote}->{checked};
 416                 return 1
 417                         if @{$ctx->{remote}->{push}} == 0;
 418                 my $fct =
 419                  { file  => \&grg_remote_push_file
 420                  , rsync => \&grg_remote_push_rsync
 421                  , sftp  => \&grg_remote_push_sftp
 422                  }->{$scheme};
 423                 error("URL scheme not supported: `$scheme'")
 424                         unless $fct;
 425                 $fct->($ctx)
 426                         or error("remote push failed");
 427                 rm(map {File::Spec->catfile($ctx->{'dir-cache'}, $_)} @{$ctx->{remote}->{push}});
 428                 return 1;
 429          }
 430         sub grg_remote_remove ($) {
 431                 my ($ctx) = @_;
 432                 #my $scheme = $ctx->{remote}->{uri}->scheme;
 433                 #my $fct =
 434                 # { file => sub {
 435                 #               File::Copy::remove_tree
 436                 #                ( map { File::Spec->catfile($ctx->{remote}->{uri}->path, $_) } @$files
 437                 #                , verbose => 1 )
 438                 #        }
 439                 # , rsync => sub {
 440                 #               IPC::Run::run([@{$ctx->{config}->{rsync}}
 441                 #                , '--verbose', '--ignore-times', '--recursive', '--delete'
 442                 #                , @$files
 443                 #                , $ctx->{remote}->{uri}])
 444                 #        }
 445                 # , sftp => sub {
 446                 #               IPC::Run::run([@{$ctx->{config}->{curl}}
 447                 #                , '--show-error'
 448                 #                , map { ('-Q', 'rm '.$_) } @$files
 449                 #                , $ctx->{remote}->{uri}])
 450                 #        }
 451                 # }->{$scheme};
 452                 #error("URL scheme not supported: `$scheme'")
 453                 #       unless $fct;
 454                 #$fct->($ctx, $ctx->{remote}->{remove})
 455                 #       or error("remote remove failed");
 456                 #return;
 457          }
 458 # grg packing
 459         sub grg_pack_fetch ($$) {
 460                 my ($ctx, $fetch_objects) = @_;
 461                 local $_;
 462                 # %remote_objects
 463                         my %remote_objects = ();
 464                         while (my ($pack_id, $pack) = each %{$ctx->{manifest}->{packs}}) {
 465                                 foreach my $obj (@{$pack->{objects}}) {
 466                                         $remote_objects{$obj} = $pack_id;
 467                                  }
 468                          }
 469                 # @packs_to_fetch
 470                         my %packs_to_fetch = ();
 471                         foreach my $obj (@$fetch_objects) {
 472                                 my @packs = ($remote_objects{$obj});
 473                                 while (my $pack_id = shift @packs) {
 474                                         if (not exists $packs_to_fetch{$pack_id}) {
 475                                                 $packs_to_fetch{$pack_id} = 1;
 476                                                 my $manifest_pack = $ctx->{manifest}->{packs}->{$pack_id};
 477                                                 error("manifest is missing a dependency pack: $pack_id")
 478                                                         unless defined $manifest_pack;
 479                                                 @packs = (@packs, @{$manifest_pack->{deps}});
 480                                          }
 481                                  }
 482                          }
 483                         my @packs_to_fetch = keys %packs_to_fetch;
 484                 my $packs_fetched = grg_remote_fetch($ctx, [@packs_to_fetch]);
 485                 foreach my $pack_id (@packs_to_fetch) {
 486                         my $pack_fetched
 487                          = exists $packs_fetched->{$pack_id}
 488                          ? $packs_fetched->{$pack_id}
 489                          : {path => File::Spec->catfile($ctx->{'dir-cache'}, $pack_id), preserve => 0};
 490                         my $manifest_pack = $ctx->{manifest}->{packs}->{$pack_id};
 491                         my $pack_key = $manifest_pack->{key};
 492                         my $pack_data;
 493                         grg_decrypt_symmetric($ctx, $pack_key, sub {
 494                                 push @{$_[0]}, ($pack_fetched->{path});
 495                                 return (@_, '>', \$pack_data);
 496                          });
 497                         my $pack_hash_algo = $manifest_pack->{hash_algo};
 498                         my $pack_hash = grg_hash($ctx
 499                          , $pack_hash_algo
 500                          , sub { return (@_, '<', \$pack_data); });
 501                         error("pack data hash differs from pack manifest hash")
 502                                 unless $pack_hash eq $manifest_pack->{hash};
 503                         rm($pack_fetched->{path})
 504                                 unless $pack_fetched->{preserve};
 505                         IPC::Run::run(['git', 'index-pack', '-v', '--stdin']
 506                          , '<', \$pack_data
 507                          , '>&2');
 508                  }
 509          }
 510         sub grg_pack_push ($$) {
 511                 my ($ctx, $push_objects) = @_;
 512                 local $_;
 513                 debug(sub{"push_objects=\n"}, $push_objects);
 514                 # %remote_objects
 515                         my %remote_objects = ();
 516                         while (my ($pack_id, $pack) = each %{$ctx->{manifest}->{packs}}) {
 517                                 foreach my $obj (@{$pack->{objects}}) {
 518                                         $remote_objects{$obj} = $pack_id;
 519                                  }
 520                          }
 521                 # @common_objects
 522                         IPC::Run::run(['git', 'cat-file', '--batch-check']
 523                          , '<', \join("\n", keys %remote_objects)
 524                          , '>', \$_)
 525                                 or error("failed to query local git objects");
 526                         my @common_objects
 527                          = map {
 528                                 if ($_ =~ m/ missing$/) { () }
 529                                 else { s/ .*//; $_ }
 530                          } (split(/\n/, $_));
 531                 # @pack_objects, @pack_deps_objects
 532                         IPC::Run::run(['git', 'rev-list', '--objects-edge', '--stdin', '--']
 533                          , '<', \join("\n", ((map {'^'.$_} @common_objects), @$push_objects))
 534                          , '>', \$_)
 535                                 or error("failed to query objects to pack");
 536                         my @pack_objects_edge = split(/\n/, $_);
 537                         foreach (@pack_objects_edge) {s/ .*//}
 538                         my @pack_objects = grep {m/^[^-]/} @pack_objects_edge;
 539                         my @pack_deps_objects = grep {s/^-//} @pack_objects_edge;
 540                 # %pack_deps
 541                         my %pack_deps = ();
 542                         foreach my $obj (@pack_deps_objects) {
 543                                 my $pack = $remote_objects{$obj};
 544                                 error("manifest is missing object dependencies")
 545                                         unless defined $pack;
 546                                 $pack_deps{$pack} = 1;
 547                          }
 548                 if (@pack_objects > 0) {
 549                         # $pack_id
 550                                 my $pack_id;
 551                                 my $pack_id_try = 0;
 552                                 while (not defined $pack_id
 553                                  or exists $ctx->{manifest}->{packs}->{$pack_id}) {
 554                                         $pack_id = grg_rand($ctx, $ctx->{config}->{'pack-filename-size'});
 555                                         $pack_id =~ s{/}{-}g;
 556                                         error("failed to pick an unused random pack filename after 512 tries; retry or increase grg.pack-filename-size")
 557                                                 if $pack_id_try++ >= 512;
 558                                  }
 559                         my $pack_key = grg_rand($ctx, $ctx->{config}->{'pack-key-size'});
 560                         my $pack_data;
 561                         IPC::Run::run(['git', 'pack-objects', '--stdout']
 562                          , '<', \join("\n", @pack_objects)
 563                          , '>', \$pack_data)
 564                                 or error("failed to pack objects to push");
 565                         my $pack_hash = grg_hash($ctx
 566                          , $ctx->{config}->{'pack-hash-algo'}
 567                          , sub { return (@_, '<', \$pack_data); });
 568                         grg_encrypt_symmetric($ctx, $pack_data, $pack_key, sub {
 569                                 push @{$_[0]}, ('--output', File::Spec->catfile($ctx->{'dir-cache'}, $pack_id));
 570                                 return @_;
 571                          });
 572                         push @{$ctx->{remote}->{push}}, $pack_id;
 573                         $ctx->{manifest}->{packs}->{$pack_id} =
 574                          { deps => [keys %pack_deps]
 575                          , hash => $pack_hash
 576                          , hash_algo => $ctx->{config}->{'pack-hash-algo'}
 577                          , key => $pack_key
 578                          , objects => \@pack_objects
 579                          };
 580                  }
 581          }
 582 # grg manifest
 583         sub grg_manifest_fetch ($) {
 584                 my ($ctx) = @_;
 585                 $ctx->{manifest} =
 586                  { 'hidden-keys' => {}
 587                  , keys => {}
 588                  , packs => {}
 589                  , refs => {}
 590                  , version => $VERSION
 591                  };
 592                 my $fetched = grg_remote_fetch($ctx, [$ctx->{'manifest-file'}]);
 593                 my $crypt = $fetched->{$ctx->{'manifest-file'}}->{path};
 594                 if (defined $crypt) {
 595                         $ctx->{remote}->{checked} = 1;
 596                         my $json;
 597                         grg_decrypt_asymmetric($ctx, sub {
 598                                 push @{$_[0]}, $crypt;
 599                                 return (@_, '>', \$json); });
 600                         rm($fetched->{$ctx->{'manifest-file'}}->{path})
 601                                 unless $fetched->{$ctx->{'manifest-file'}}->{preserve};
 602                         my $manifest;
 603                         ($manifest = JSON::decode_json($json) and ref $manifest eq 'HASH')
 604                                 or error("failed to decode JSON manifest");
 605                         $ctx->{manifest} = {%{$ctx->{manifest}}, %$manifest};
 606                         foreach my $slot (qw(keys hidden-keys)) {
 607                                 while (my ($fpr, $uid) = each %{$ctx->{manifest}->{$slot}}) {
 608                                         my %keys = gpg_fingerprint($ctx, '0x'.$fpr, ['E']);
 609                                         my ($fpr, $uid) = each %keys;
 610                                         $ctx->{config}->{$slot}->{$fpr} = $uid;
 611                                  }
 612                          }
 613                  }
 614                 else {
 615                         if ($ctx->{command} eq 'push' or $ctx->{command} eq 'list for-push') {
 616                                 $ctx->{remote}->{checked} = 0;
 617                          }
 618                         elsif ($ctx->{remote}->{checking}) {
 619                                 exit 100;
 620                          }
 621                         else {
 622                                 error("remote checking failed");
 623                          }
 624                  }
 625          }
 626         sub grg_manifest_push ($) {
 627                 my ($ctx) = @_;
 628                 foreach my $slot (qw(keys hidden-keys)) {
 629                         $ctx->{manifest}->{$slot} = {};
 630                         while (my ($fpr, $uid) = each %{$ctx->{config}->{$slot}}) {
 631                                 $ctx->{manifest}->{$slot}->{$fpr} = $uid;
 632                          }
 633                  }
 634                 my $json = JSON::encode_json($ctx->{manifest})
 635                         or error("failed to encode JSON manifest");
 636                 grg_encrypt_asymmetric($ctx, $json, sub {
 637                         push @{$_[0]}
 638                          , ('--output', File::Spec->catfile($ctx->{'dir-cache'}, $ctx->{'manifest-file'}));
 639                         return @_; });
 640                 push @{$ctx->{remote}->{push}}, $ctx->{'manifest-file'};
 641          }
 642 # grg config
 643         sub grg_config_read($) {
 644                 my ($ctx) = @_;
 645                 my $cfg = $ctx->{config};
 646                 local $/ = "\n";
 647
 648                 foreach my $name (qw(gpg signingkey keys)
 649                  , grep {       !m/^(gpg|signingkey|keys)$/ } (keys %$cfg)) {
 650                         my $value;
 651                         IPC::Run::run(['git', 'config', '--get', 'remote.'.$ctx->{remote}->{name}.'.'.$name, '.+'], '>', \$value) or
 652                         IPC::Run::run(['git', 'config', '--get', 'grg.'.$name, '.+'], '>', \$value) or 1;
 653                         if ($name eq 'signingkey') {
 654                                 IPC::Run::run(['git', 'config', '--get', 'user.'.$name, '.+'], '>', \$value)
 655                                         if (not $value);
 656                                 chomp $value;
 657                                 my %keys = gpg_fingerprint($ctx, $value, ['S']);
 658                                 warning("signing key ID is not matching a unique key: taking only one")
 659                                         unless scalar(keys %keys) == 1;
 660                                 my ($fpr, $uid) = each %keys;
 661                                 $cfg->{$name} = {fpr => $fpr, uid => $uid};
 662                          }
 663                         elsif ($name eq 'keys' or $name eq 'hidden-keys') {
 664                                 IPC::Run::run(['git', 'config', '--get', 'user.'.$name, '.+'], '>', \$value)
 665                                         if (not $value);
 666                                 chomp $value;
 667                                 my @ids = split(/,/, $value);
 668                                 if (@ids > 0) {
 669                                         foreach my $key (@ids) {
 670                                                 my %keys = gpg_fingerprint($ctx, $key, ['E']);
 671                                                 while (my ($fpr, $uid) = each %keys) {
 672                                                         $cfg->{$name}->{$fpr} = $uid;
 673                                                  }
 674                                          }
 675                                  }
 676                          }
 677                         elsif (grep(/^$name$/, qw(curl gpg rsync))) {
 678                                 IPC::Run::run(['git', 'config', '--get', $name.'.program', '.+'], '>', \$value)
 679                                         if (not $value);
 680                                 $cfg->{$name} = [split(' ', $value)]
 681                                         if $value;
 682                          }
 683                         else {
 684                                 chomp $value;
 685                                 $cfg->{$name} = $value
 686                                         if $value;
 687                          }
 688                  }
 689                 error("no signingkey configured; to do so you may use one of following commands:\n"
 690                  , "\t\$ git config remote.'$ctx->{remote}->{name}'.signingkey \$your_openpgp_id\n"
 691                  , "\t\$ git config grg.signingkey \$your_openpgp_id\n"
 692                  , "\t\$ git config user.signingkey \$your_openpgp_id"
 693                  ) unless defined $cfg->{signingkey};
 694                 if ( (scalar (keys %{$cfg->{keys}}) == 0)
 695                  and (scalar (keys %{$cfg->{'hidden-keys'}}) == 0) ) {
 696                         $cfg->{keys} = { $cfg->{signingkey}->{fpr} => $cfg->{signingkey}->{uid} };
 697                  }
 698
 699                 debug(sub{'config='},$cfg);
 700          }
 701 # grg system
 702         sub grg_connect ($) {
 703                 my ($ctx) = @_;
 704                 grg_config_read($ctx);
 705                 grg_manifest_fetch($ctx);
 706          }
 707         sub grg_disconnect ($) {
 708                 my ($ctx) = @_;
 709                 grg_remote_push($ctx);
 710          }
 711 # grg commands
 712         sub gpg_command_answer ($) {
 713                 my @cmd = @_;
 714                 debug(sub{join('', @cmd)."\n"});
 715                 print STDOUT (@cmd, "\n");
 716          }
 717         sub grg_command_capabilities ($) {
 718                 my ($ctx) = @_;
 719                 $ctx->{command} = 'capabilities';
 720                 gpg_command_answer("fetch");
 721                 gpg_command_answer("push");
 722                 gpg_command_answer("");
 723                 STDOUT->flush;
 724          }
 725         sub grg_command_fetch ($$) {
 726                 my ($ctx, $fetch_refs) = @_;
 727                 $ctx->{command} = 'fetch';
 728                 debug(sub{"fetch_refs="}, $fetch_refs);
 729                 grg_connect($ctx);
 730                 # @fetch_objects
 731                         my @fetch_objects= ();
 732                         foreach my $ref (@$fetch_refs) {
 733                                 push @fetch_objects, $ref->{sha1};
 734                          }
 735                 grg_pack_fetch($ctx, \@fetch_objects);
 736          }
 737         sub grg_command_list ($$) {
 738                 my ($ctx, $command) = @_;
 739                 $ctx->{command} = $command;
 740                 grg_connect($ctx);
 741                 my $manifest_refs = $ctx->{manifest}->{refs};
 742                 while (my ($ref, $obj) = each %$manifest_refs) {
 743                         if ($obj =~ m|^ref: *(.*) *$|) {
 744                                 $obj = $manifest_refs->{$1};
 745                          }
 746                         gpg_command_answer("$obj $ref")
 747                                 if defined $obj;
 748                  };
 749                 gpg_command_answer("");
 750          }
 751         sub grg_command_push ($$) {
 752                 my ($ctx, $push_refs) = @_;
 753                 local $_;
 754                 $ctx->{command} = 'push';
 755                 debug(sub{"push_refs="}, $push_refs);
 756                 grg_connect($ctx);
 757                 # @push_objects
 758                         my @push_objects= ();
 759                         foreach my $ref (@$push_refs) {
 760                                 IPC::Run::run(['git', 'rev-list', '--ignore-missing', '--max-count=1', $ref->{src}, '--']
 761                                  , '>', \$_)
 762                                         or error("failed to dereference ref to push: ".$ref->{src});
 763                                 chomp;
 764                                 $ref->{src_obj} = $_;
 765                                 push @push_objects, $_;
 766                          }
 767                 grg_pack_push($ctx, \@push_objects);
 768                 my $manifest_refs = $ctx->{manifest}->{refs};
 769                 foreach my $ref (@$push_refs) {
 770                         $manifest_refs->{$ref->{dst}} = $ref->{src_obj};
 771                  }
 772                 $manifest_refs->{HEAD} = 'ref: refs/heads/master'
 773                  unless defined $manifest_refs->{HEAD};
 774                 grg_manifest_push($ctx);
 775                 grg_disconnect($ctx);
 776          }
 777         sub grg_commands(@) {
 778                 my ($ctx) = @_;
 779                 my $line = undef;
 780                 local $/ = "\n";
 781                 #STDOUT->autoflush(1);
 782                 while (defined $line or (not eof(*STDIN) and
 783                         (defined($line = readline(*STDIN)))
 784                          ? (chomp $line or 1)
 785                          : error("readline failed: $!")
 786                  )) {
 787                         debug(sub{"line=\"",$line,"\"\n"});
 788                         $ctx->{command} = undef;
 789                         if ($line eq 'capabilities') {
 790                                 grg_command_capabilities($ctx);
 791                                 $line = undef;
 792                          }
 793                         elsif ($line =~ m/^fetch .*$/) {
 794                                 my @refs = ();
 795                                 my ($sha1, $name);
 796                                 while ((defined $line or (not eof(*STDIN) and
 797                                         ((defined($line = readline(*STDIN)))
 798                                          ? (chomp $line or 1)
 799                                          : error("readline failed: $!")))) and
 800                                         (($sha1, $name) = ($line =~ m/^fetch ([0-9a-f]{40}) (.+)$/))
 801                                  ) {
 802                                         debug(sub{"fetch line=\"",$line,"\"\n"});
 803                                         push @refs, {sha1=>$sha1, name=>$name};
 804                                         $line = undef;
 805                                  }
 806                                 error("failed to parse command: $line")
 807                                         if @refs == 0;
 808                                 grg_command_fetch($ctx, \@refs);
 809                          }
 810                         elsif ($line eq 'list' or $line eq 'list for-push') {
 811                                 grg_command_list($ctx, $line);
 812                                 $line = undef;
 813                          }
 814                         elsif ($line =~ m/^push .*$/) {
 815                                 my @refs = ();
 816                                 my ($force, $src, $dst);
 817                                 while ((defined $line or (not eof(*STDIN) and
 818                                         ((defined($line = readline(*STDIN)))
 819                                          ? (chomp $line or 1)
 820                                          : error("readline failed: $!")))) and
 821                                         (($force, $src, $dst) = ($line =~ m/^push (\+)?([^:]+):(.+)$/))
 822                                  ) {
 823                                         debug(sub{"push line=\"",$line,"\"\n"});
 824                                         push @refs, {force=>(defined $force), src=>$src, dst=>$dst};
 825                                         $line = undef;
 826                                  }
 827                                 error("failed to parse command: $line")
 828                                         if @refs == 0;
 829                                 grg_command_push($ctx, \@refs);
 830                          }
 831                         elsif ($line =~ m/^$/) {
 832                                 $line = undef;
 833                                 {
 834                                         local $SIG{'PIPE'} = 'IGNORE';
 835                                         gpg_command_answer("");
 836                                 }
 837                                 return 0;
 838                          }
 839                         else {
 840                                 warning("unsupported command supplied: `$line'");
 841                                 $line = undef;
 842                          }
 843                  }
 844          }
 845 sub main {
 846         $ENV{GIT_DIR} = $ENV{GIT_DIR} || '.git';
 847         $ENV{GITCEPTION} = ($ENV{GITCEPTION} || '') . '+';
 848         my $ctx =
 849          { command => undef
 850          , config =>
 851                  { curl => ['curl']
 852                  , gpg => ['gpg']
 853                  , keys => {}
 854                  , 'hidden-keys' => {}
 855                  , 'manifest-hash-algo' => 'SHA224' # NOTE: SHA512, SHA384, SHA256, SHA224 supported.
 856                  , 'pack-filename-size' => 42
 857                  , 'pack-hash-algo' => 'SHA224' # NOTE: SHA512, SHA384, SHA256, SHA224 supported.
 858                  , 'pack-key-size' => 64
 859                  , signingkey => undef
 860                  , rsync => ['rsync']
 861                  }
 862          , 'dir-cache' => undef
 863          , manifest => {}
 864          , 'manifest-file' => undef
 865          , remote =>
 866                  { checking => 0
 867                  , checked => undef
 868                  , name => undef
 869                  , uri => undef
 870                  , push => []
 871                  }
 872          };
 873         Getopt::Long::Configure
 874          ( 'auto_version'
 875          , 'pass_through'
 876          , 'require_order'
 877          );
 878         Getopt::Long::GetOptions
 879          ( help => sub { Pod::Usage::pod2usage
 880                  ( -exitstatus => 0
 881                  , -sections   => ['SYNOPSIS', 'OPTIONS', 'REMOTES', 'CONFIG']
 882                  , -verbose    => 99 ); }
 883          , man => sub { Pod::Usage::pod2usage(-verbose => 2); }
 884          , check => sub {
 885                         $ctx->{remote}->{checking} = 1;
 886                  }
 887          );
 888         if (not $ctx->{remote}->{checking}) {
 889                 my $name = shift @ARGV;
 890                 Pod::Usage::pod2usage(-verbose => 1)
 891                         unless defined $name;
 892                 ($ctx->{remote}->{name}) = ($name =~ m/^((\w|-)+)$/);
 893                 error("valid name of remote Git required, got: `$name'")
 894                         unless $ctx->{remote}->{name};
 895          }
 896         my $uri = shift @ARGV;
 897         Pod::Usage::pod2usage(-verbose => 1)
 898                 unless defined $uri;
 899         $ctx->{remote}->{uri} = URI->new($uri);
 900         error("valid URL of remote Git required, got: `$uri'")
 901                 unless $ctx->{remote}->{uri};
 902         my $fragment = $ctx->{remote}->{uri}->fragment;
 903         $fragment = ''
 904                 unless defined $fragment;
 905         $ctx->{'manifest-file'} = grg_hash($ctx
 906          , $ctx->{config}->{'manifest-hash-algo'}
 907          , sub { return (@_, '<', \$fragment); });
 908         if (-d $ENV{GIT_DIR}) {
 909                 $ctx->{'dir-cache'} = File::Spec->catdir
 910                  ( $ENV{GIT_DIR}, 'cache', 'remotes'
 911                  , $ctx->{remote}->{name}, 'gpg');
 912                 &mkdir($ctx->{'dir-cache'});
 913          }
 914         else {
 915                 $ctx->{'dir-cache'} = File::Temp->tempdir('grg_cache_XXXXXXXX', CLEANUP => 1);
 916          }
 917         debug(sub{"ctx="},$ctx);
 918         grg_commands($ctx);
 919  }
 920 main;
 921 1;
 922 __END__
 923
 924 =encoding utf8
 925
 926 =head1 NAME
 927
 928 git-remote-gpg - git-remote-helpers(1) to encrypt remote repository through gpg(1)
 929
 930 =head1 SYNOPSIS
 931
 932 =item git-remote-gpg $gpg_remote $gpg_url
 933
 934 =item git-remote-gpg --check $gpg_url
 935
 936 =head1 OPTIONS
 937
 938 =over 8
 939
 940 =item B<-h>, B<--help>
 941
 942 =item B<--version>
 943
 944 =back
 945
 946 =head1 REMOTES
 947
 948 =head2 Via rsync(1)
 949
 950 =item git remote add $remote gpg::rsync:${user:+$user@}$host:$path
 951
 952 =item git remote add $remote gpg::rsync://${user:+$user@}$host${port:+:$port}/$path
 953
 954 =head2 Via curl(1)
 955
 956 =item git remote add $remote gpg::sftp://${user:+$user@}$host${port:+:$port}/$path
 957
 958 =head2 Via File::Copy(3pm)
 959
 960 =item git remote add $remote gpg::file://$path
 961
 962 =head1 CONFIG
 963
 964 =head2 git-config(1)
 965
 966 =over 8
 967
 968 =item B<grg.curl>, B<remote.$remote.curl>
 969
 970 =item B<grg.gpg>, B<remote.$remote.gpg>
 971
 972 =item B<grg.keys>, B<remote.$remote.keys>
 973
 974 =item B<grg.hidden-keys>, B<remote.$remote.hidden-keys>
 975
 976 =item B<grg.manifest-hash-algo>, B<remote.$remote.manifest-hash-algo>
 977
 978 =item B<grg.pack-filename-size>, B<remote.$remote.pack-filename-size>
 979
 980 =item B<grg.pack-hash-algo>, B<remote.$remote.pack-hash-algo>
 981
 982 =item B<grg.pack-key-size>, B<remote.$remote.pack-key-size>
 983
 984 =item B<grg.signingkey>, B<remote.$remote.signingkey>
 985
 986 =item B<grg.rsync>, B<remote.$remote.rsync>
 987
 988 =back
 989
 990 =cut