git-remote-gpg

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