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