git-remote-gpg

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