git-remote-gpg

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