#!/usr/bin/perl
our $VERSION = '2014.01.28';
# License
	# This file is a git-remote-helpers(1) to use a gpg(1)
	# as a cryptographic layer below git(1)'s objects.
	# Copyright (C) 2014  Julien Moutinho
	#
	# This program is free software: you can redistribute it and/or modify
	# it under the terms of the GNU General Public License as published
	# by the Free Software Foundation, either version 3 of the License,
	# or any later version.
	#
	# This program is distributed in the hope that it will be useful,
	# but WITHOUT ANY WARRANTY; without even the implied warranty
	# of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
	# See the GNU General Public License for more details.
	#
	# You should have received a copy of the GNU General Public License
	# along with this program.  If not, see <http://www.gnu.org/licenses/>.
# Dependencies
	use strict;
	use warnings FATAL => qw(all);
	use Carp;
	use Cwd;
	use File::Basename;
	use File::Copy;
	use File::Path;
	use File::Spec::Functions qw(:ALL);
	use File::Temp;
	use Getopt::Long;
	use IPC::Run;
		# NOTE: to debug: IPCRUNDEBUG=basic|data|details|gory
	use IO::Handle;
	use JSON;
	use POSIX qw(WNOHANG);
	use URI;
	
	require Pod::Usage;
	require Data::Dumper;
# Trace utilities
	sub trace (@) {
		foreach my $msg (@_) {
			print STDERR $msg
				if defined $msg;
		 }
	 }
	sub debug (@) {
		my $call = (caller(1))[3];
		if ($ENV{TRACE}) {
			trace
			 ( "\e[35mDEBUG\e[m"
			 , "\e[30m\e[1m.", join('.', $call."\e[m")
			 , " ", (map {
				ref $_ eq 'CODE'
				 ? $_->()
				 : Data::Dumper::Dumper($_)
				} @_)
			 );
		 }
		return 1;
	 }
	sub info (@) {
		my $call = (caller(1))[3];
		trace
		 ( "\e[32mINFO\e[m"
		 , "\e[30m\e[1m.", join('.', $call."\e[m")
		 , " ", (ref $_ eq 'CODE'?(join("\n      ", $_->()), "\n"):(@_, "\n"))
		 );
	 }
	sub warning (@) {
		local $Carp::CarpLevel = 1;
		carp("\e[33mWARNING\e[m ", @_, "\n\t");
	 }
	sub error (@) {
		local $Carp::CarpLevel = 1;
		croak("\e[31mERROR\e[m ", @_, "\n\t");
	 }
# System utilities
	sub rm ($) {
		my ($file) = @_;
		debug(sub{"file="},$file);
		unlink($file)
			or error("rm $file");
	 }
	sub mkdir ($) {
		my ($dir) = @_;
		debug(sub{"dir=\"$dir\"\n"});
		File::Path::make_path($dir, {verbose=>0, error => \my $error});
		if (@$error) {
			for my $diag (@$error) {
				my ($dir, $message) = %$diag;
				if ($dir eq '') {
					print "general error: $message\n";
				 }
				else {
					print "problem mkdir $dir: $message\n";
				 }
			 }
		 }
	 }
# grg crypto
	sub grg_rand ($$) {
		my ($ctx, $size) = @_;
		local $_;
		IPC::Run::run([@{$ctx->{config}->{gpg}}
		 , '--armor', '--gen-rand', '1', $size]
		 , '>', \$_)
			or error("failed to get random bits");
		chomp;
		return $_;
	 }
	sub grg_hash ($$;$) {
		my ($ctx, $algo, $run) = @_;
		$run = sub {return @_} unless defined $run;
		my $hash;
		IPC::Run::run($run->([@{$ctx->{config}->{gpg}}
		 , '--with-colons', '--print-md', $algo]
		 , '>', \$hash))
			or error("failed to hash data");
		return ((split(':', $hash))[2]);
	 }
	sub gpg_fingerprint($$$) {
		my ($ctx, $id, $caps_needed) = @_;
		my ($output);
		my %h = ();
		if (IPC::Run::run([@{$ctx->{config}->{gpg}}
		 , '--fixed-list-mode', '--with-colons', '--with-fingerprint', '--list-keys', $id]
		 , '>', \$output)) {
			my @lines = split(/\n/,$output);
			while (my $line = shift @lines) {
				if (my ($longkeyid, $caps) = $line =~ m/^pub:[^:]*:[^:]*:[^:]*:([^:]*):[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:([^:]+):.*$/) {
					my $skip = 0;
					foreach my $cap (@$caps_needed) {
						if (not ($caps =~ m/$cap/)) {
							warning("skipping key 0x$longkeyid which has not usable capability: $cap, but matches: `$id'");
							$skip = 1;
						 }
					 }
					if (not $skip) {
						my $fpr = undef;
						my $uid = undef;
						while ((not defined $fpr or not defined $uid)
						 and $line = shift @lines) {
							(not defined $fpr and (($fpr) = $line =~ m/^fpr:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:([0-9A-F]+):.*$/)) or
							(not defined $uid and (($uid) = $line =~ m/^uid:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:([^:]+):.*$/)) or
							1;
						 }
						error("unable to extract fingerprint and user ID")
							unless defined $fpr
							and    defined $uid;
						$h{$fpr} = $uid;
					 }
				 }
			 }
		 }
		error("unable to find any OpenPGP key with usable capability: ".join('', @$caps_needed)." for: `$id'")
			unless scalar(%h) gt 0;
		debug(sub{"$id -> "}, \%h);
		return %h;
	 }
	sub grg_encrypt_symmetric ($$$;$) {
		my ($ctx, $clear, $key, $run) = @_;
		$run = sub {return @_} unless defined $run;
		IPC::Run::run($run->([@{$ctx->{config}->{gpg}}
		 , '--batch', '--yes'
		 , '--compress-algo', 'none'
		 , '--force-mdc'
		 , '--passphrase-fd', '3'
		 , '--s2k-mode', '1'
		 , '--trust-model', 'always'
		 , '--symmetric']
		 , '<', \$clear, '3<', \$key))
			or error("failed to encrypt symmetrically data");
	 }
	sub grg_decrypt_symmetric ($$$;$) {
		my ($ctx, $key, $run) = @_;
		debug(sub{'ctx='}, $ctx);
		debug(sub{'key='}, $key);
		$run = sub {return @_} unless defined $run;
		IPC::Run::run($run->([@{$ctx->{config}->{gpg}}
		 , '--batch', '--no-default-keyring', '--keyring', '/dev/null', '--secret-keyring', '/dev/null'
		 , '--passphrase-fd', '3', '--quiet', '--decrypt']
		 , '3<', \$key))
			or error("failed to decrypt symmetrically data");
	 }
	sub grg_encrypt_asymmetric ($$;$) {
		my ($ctx, $clear, $run) = @_;
		$run = sub {return @_} unless defined $run;
		my @recipients = 
		 ( (map { ('--recipient', '0x'.$_) } (keys %{$ctx->{config}->{keys}}))
		 , (map { ('--hidden-recipient', '0x'.$_) } (keys %{$ctx->{config}->{'hidden-keys'}})) );
		@recipients = ('--default-recipient-self')
			if @recipients == 0;
		IPC::Run::run($run->([@{$ctx->{config}->{gpg}}
		 , '--batch', '--yes'
		 , '--compress-algo', 'none'
		 , '--trust-model', 'always'
		 , '--sign', '--encrypt'
		 , ($ctx->{config}->{signingkey}->{fpr} ? ('--local-user', $ctx->{config}->{signingkey}->{fpr}) : ())
		 , @recipients ]
		 , '<', \$clear))
			or error("failed to encrypt asymmetrically data");
	 }
	sub grg_decrypt_asymmetric ($$;$) {
		my ($ctx, $run) = @_;
		my ($clear, $status);
		$run = sub {return @_} unless defined $run;
		IPC::Run::run($run->([@{$ctx->{config}->{gpg}}
		 , '--batch', '--no-default-keyring',
		 , '--status-fd', '3', '--quiet', '--decrypt']
		 , '>', \$clear, '3>', \$status))
			or error("failed to decrypt asymmetrically data");
		debug(sub{"status=\n$status"});
		my @lines = split(/\n/,$status);
		my ($enc_to, $goodsig, $validsig, $validpub, $goodmdc);
		foreach my $line (@lines) {
			(not defined $enc_to and (($enc_to)   = $line =~ m/^\[GNUPG:\] ENC_TO ([0-9A-F]+).*$/)) or
			(not defined $goodsig and (($goodsig) = $line =~ m/^\[GNUPG:\] GOODSIG ([0-9A-F]+).*$/)) or
			(not defined $goodmdc and (($goodmdc) = $line =~ m/^\[GNUPG:\] (GOODMDC)$/)) or
			(not defined $validsig and not defined $validpub and (($validsig, $validpub)
				 = $line =~ m/^\[GNUPG:\] VALIDSIG ([0-9A-F]+) [^ ]+ [^ ]+ [^ ]+ [^ ]+ [^ ]+ [^ ]+ [^ ]+ [^ ]+ ([0-9A-F]+).*$/)) or
			1;
		 }
		error("data expected to be encrypted")
			unless $enc_to;
		debug(sub{"enc_to=$enc_to\n"});
		error("data expected to be signed")
			unless $goodsig;
		debug(sub{"goodsig=$goodsig\n"});
		error("modification detection code incorrect")
			unless $goodmdc;
		debug(sub{"good_mdc=$goodmdc\n"});
		error("data signature invalid")
			unless $validsig and $validpub;
		debug(sub{"validsig=$validsig\n"});
		debug(sub{"validpub=$validpub\n"});
		error("data signature refused")
			unless exists $ctx->{config}->{keys}->{$validpub}
			or exists $ctx->{config}->{'hidden-keys'}->{$validpub};
		debug(sub{"accepted:$validpub\n"});
		return $clear;
	 }
# grg remote I/O
	sub grg_remote_fetch_file ($$$) {
		my ($ctx, $files, $fetch_files) = @_;
		# NOTE: avoid File::Copy::copy().
		while (my ($file, undef) = each %$fetch_files) {
			my $path = File::Spec->catfile($ctx->{remote}->{uri}->file, $file);
			debug(sub{'test path='}, $path);
			if (-r $path) {
				my $h = $fetch_files->{$file};
				$h->{path}     = $path;
				$h->{preserve} = 1;
			 }
			else { return 0; }
		 }
		return 1;
	 }
	sub grg_remote_fetch_rsync ($$$) {
		my ($ctx, $files, $fetch_files) = @_;
		my $uri  = $ctx->{remote}->{uri}->clone;
		$uri->scheme(undef);
		$uri->fragment(undef);
		$uri->query(undef);
		$uri = $uri->as_string;
		IPC::Run::run([@{$ctx->{config}->{rsync}}
		 , '--verbose', '--ignore-times', '--inplace', '--progress'
		 , (map { File::Spec->catfile($uri, $_) } @$files)
		 , $ctx->{'dir-cache'}.'/']
		 , '>&2')
	 }
	sub grg_remote_fetch_sftp ($$$) {
		my ($ctx, $files, $fetch_files) = @_;
		IPC::Run::run([@{$ctx->{config}->{curl}}
		 , '--show-error'
		 , '--output', File::Spec->catfile($ctx->{'dir-cache'}, '#1')
		 , File::Spec->catfile($ctx->{remote}->{uri}, '{'.join(',',@$files).'}') ])
	 }
	sub grg_remote_fetch ($$) {
		my ($ctx, $files) = @_;
		debug(sub{'files='}, $files);
		my $scheme = $ctx->{remote}->{uri}->scheme;
		my $fetch_files = {map { $_ => { path => File::Spec->catfile($ctx->{'dir-cache'}, $_), preserve => 0 } } @$files};
		my $fct =
		 { file  => \&grg_remote_fetch_file
		 , rsync => \&grg_remote_fetch_rsync
		 , sftp  => \&grg_remote_fetch_sftp
		 }->{$scheme};
		error("URL scheme not supported: `$scheme'")
			unless $fct;
		debug(sub{'fetch_files='}, $fetch_files);
		$fct->($ctx, $files, $fetch_files)
			or $fetch_files = {};
		debug(sub{'fetch_files='}, $fetch_files);
		return $fetch_files;
	 }
	sub grg_remote_init_file ($) {
		my ($ctx) = @_;
		my $dst = $ctx->{remote}->{uri}->file;
		&mkdir($dst);
		return 1;
	 }
	sub grg_remote_init_rsync ($) {
		my ($ctx) = @_;
		my $tmp = File::Temp->tempdir(CLEANUP => 1);
		my $path = $ctx->{remote}->{uri}->path;
		my $uri  = $ctx->{remote}->{uri}->clone;
		$uri->fragment(undef);
		$uri->path(undef);
		$uri->query(undef);
		&mkdir(File::Spec->catdir($tmp, $path));
		IPC::Run::run([@{$ctx->{config}->{rsync}}
		 , '--verbose', '--recursive', '--relative'
		 , '--exclude=*', '.'
		 , File::Spec->catfile($uri->as_string)]
		 , init => sub { chdir $tmp or die $!; })
	 }
	sub grg_remote_init_sftp ($) {
		my ($ctx) = @_;
		my $path = $ctx->{remote}->{uri}->path;
		my $uri  = $ctx->{remote}->{uri}->clone;
		$uri->fragment(undef);
		$uri->path(undef);
		$uri->query(undef);
		IPC::Run::run([@{$ctx->{config}->{curl}}
		 , '--show-error', '--ftp-create-dirs'
		 , '-Q', "+mkdir ".$path
		 , $uri->as_string])
	 }
	sub grg_remote_init ($) {
		my ($ctx) = @_;
		my $scheme = $ctx->{remote}->{uri}->scheme;
		my $fct =
		 { file  => \&grg_remote_init_file
		 , rsync => \&grg_remote_init_rsync
		 , sftp  => \&grg_remote_init_sftp
		 }->{$scheme};
		error("URL scheme not supported: `$scheme'")
			unless $fct;
		$fct->($ctx)
			or error("remote init failed");
		return;
	 }
	sub grg_remote_push_file ($$) {
		my ($ctx, $files) = @_;
		my $ok = 1;
		foreach my $file (@$files) {
			my $src = File::Spec->catfile($ctx->{'dir-cache'}, $file);
			my $dst = File::Spec->catfile($ctx->{remote}->{uri}->file, $file);
			debug(sub{"File::Copy::move('$src', '$dst')\n"});
			if (not File::Copy::move($src, $dst)) {
				$ok = 0;
				last;
			 }
		 }
		return $ok;
	 }
	sub grg_remote_push_rsync ($$) {
		my ($ctx, $files) = @_;
		my $uri  = $ctx->{remote}->{uri}->clone;
		$uri->fragment('');
		$uri->query('');
		IPC::Run::run([@{$ctx->{config}->{rsync}}
		 , '--verbose', '--relative'
		 , @$files
		 , $uri->as_string])
	 }
	sub grg_remote_push_sftp ($$) {
		my ($ctx, $files) = @_;
		my $uri  = $ctx->{remote}->{uri}->clone;
		$uri->fragment('');
		$uri->query('');
		IPC::Run::run([@{$ctx->{config}->{curl}}
		 , '--show-error', '--ftp-create-dirs', '--upload-file'
		 , '{'.join(',', @$files).'}'
		 , $uri->as_string.'/'])
	 }
	sub grg_remote_push ($) {
		my ($ctx) = @_;
		my $scheme = $ctx->{remote}->{uri}->scheme;
		grg_remote_init($ctx)
			unless $ctx->{remote}->{checked};
		return 1
			if @{$ctx->{remote}->{push}} == 0;
		my $fct =
		 { file  => \&grg_remote_push_file
		 , rsync => \&grg_remote_push_rsync
		 , sftp  => \&grg_remote_push_sftp
		 }->{$scheme};
		error("URL scheme not supported: `$scheme'")
			unless $fct;
		$fct->($ctx, $ctx->{remote}->{push})
			or error("remote push failed");
		return 1;
	 }
	sub grg_remote_remove ($) {
		my ($ctx) = @_;
		#my $scheme = $ctx->{remote}->{uri}->scheme;
		#my $fct =
		# { file => sub {
		#		File::Copy::remove_tree
		#		 ( map { File::Spec->catfile($ctx->{remote}->{uri}->path, $_) } @$files
		#		 , verbose => 1 )
		#	 }
		# , rsync => sub {
		#		IPC::Run::run([@{$ctx->{config}->{rsync}}
		#		 , '--verbose', '--ignore-times', '--recursive', '--delete'
		#		 , @$files
		#		 , $ctx->{remote}->{uri}])
		#	 }
		# , sftp => sub {
		#		IPC::Run::run([@{$ctx->{config}->{curl}}
		#		 , '--show-error'
		#		 , map { ('-Q', 'rm '.$_) } @$files
		#		 , $ctx->{remote}->{uri}])
		#	 }
		# }->{$scheme};
		#error("URL scheme not supported: `$scheme'")
		#	unless $fct;
		#$fct->($ctx, $ctx->{remote}->{remove})
		#	or error("remote remove failed");
		#return;
	 }
# grg packing
	sub grg_pack_fetch ($$) {
		my ($ctx, $fetch_objects) = @_;
		local $_;
		# %remote_objects
			my %remote_objects = ();
			while (my ($pack_id, $pack) = each %{$ctx->{manifest}->{packs}}) {
				foreach my $obj (@{$pack->{objects}}) {
					$remote_objects{$obj} = $pack_id;
				 }
			 }
		# @packs_to_fetch
			my %packs_to_fetch = ();
			foreach my $obj (@$fetch_objects) {
				my @packs = ($remote_objects{$obj});
				while (my $pack_id = shift @packs) {
					if (not exists $packs_to_fetch{$pack_id}) {
						$packs_to_fetch{$pack_id} = 1;
						my $manifest_pack = $ctx->{manifest}->{packs}->{$pack_id};
						error("manifest is missing a dependency pack: $pack_id")
							unless defined $manifest_pack;
						@packs = (@packs, @{$manifest_pack->{deps}});
					 }
				 }
			 }
			my @packs_to_fetch = keys %packs_to_fetch;
		my $packs_fetched = grg_remote_fetch($ctx, [@packs_to_fetch]);
		foreach my $pack_id (@packs_to_fetch) {
			my $pack_fetched
			 = exists $packs_fetched->{$pack_id}
			 ? $packs_fetched->{$pack_id}
			 : {path => File::Spec->catfile($ctx->{'dir-cache'}, $pack_id), preserve => 0};
			my $manifest_pack = $ctx->{manifest}->{packs}->{$pack_id};
			my $pack_key = $manifest_pack->{key};
			my $pack_data;
			grg_decrypt_symmetric($ctx, $pack_key, sub {
				push @{$_[0]}, ($pack_fetched->{path});
				return (@_, '>', \$pack_data);
			 });
			my $pack_hash_algo = $manifest_pack->{hash_algo};
			my $pack_hash = grg_hash($ctx
			 , $pack_hash_algo
			 , sub { return (@_, '<', \$pack_data); });
			error("pack data hash differs from pack manifest hash")
				unless $pack_hash eq $manifest_pack->{hash};
			rm($pack_fetched)
				unless $pack_fetched->{preserve};
			IPC::Run::run(['git', 'index-pack', '-v', '--stdin']
			 , '<', \$pack_data
			 , '>&2');
		 }
	 }
	sub grg_pack_push ($$) {
		my ($ctx, $push_objects) = @_;
		local $_;
		debug(sub{"push_objects=\n"}, $push_objects);
		# %remote_objects
			my %remote_objects = ();
			while (my ($pack_id, $pack) = each %{$ctx->{manifest}->{packs}}) {
				foreach my $obj (@{$pack->{objects}}) {
					$remote_objects{$obj} = $pack_id;
				 }
			 }
		# @common_objects
			IPC::Run::run(['git', 'cat-file', '--batch-check']
			 , '<', \join("\n", keys %remote_objects)
			 , '>', \$_)
				or error("failed to query local git objects");
			my @common_objects
			 = map {
				if ($_ =~ m/ missing$/) { () }
				else { s/ .*//; $_ }
			 } (split(/\n/, $_));
		# @pack_objects, @pack_deps_objects
			IPC::Run::run(['git', 'rev-list', '--objects-edge', '--stdin', '--']
			 , '<', \join("\n", ((map {'^'.$_} @common_objects), @$push_objects))
			 , '>', \$_)
				or error("failed to query objects to pack");
			my @pack_objects_edge = split(/\n/, $_);
			foreach (@pack_objects_edge) {s/ .*//}
			my @pack_objects = grep {m/^[^-]/} @pack_objects_edge;
			my @pack_deps_objects = grep {s/^-//} @pack_objects_edge;
		# %pack_deps
			my %pack_deps = ();
			foreach my $obj (@pack_deps_objects) {
				my $pack = $remote_objects{$obj};
				error("manifest is missing object dependencies")
					unless defined $pack;
				$pack_deps{$pack} = 1;
			 }
		if (@pack_objects > 0) {
			# $pack_id
				my $pack_id;
				my $pack_id_try = 0;
				while (not defined $pack_id
				 or exists $ctx->{manifest}->{packs}->{$pack_id}) {
					$pack_id = grg_rand($ctx, $ctx->{config}->{'pack-filename-size'});
					$pack_id =~ s{/}{-}g;
					error("failed to pick an unused random pack filename after 512 tries; retry or increase grg.pack-filename-size")
						if $pack_id_try++ >= 512;
				 }
			my $pack_key = grg_rand($ctx, $ctx->{config}->{'pack-key-size'});
			my $pack_data;
			IPC::Run::run(['git', 'pack-objects', '--stdout']
			 , '<', \join("\n", @pack_objects)
			 , '>', \$pack_data)
				or error("failed to pack objects to push");
			my $pack_hash = grg_hash($ctx
			 , $ctx->{config}->{'pack-hash-algo'}
			 , sub { return (@_, '<', \$pack_data); });
			grg_encrypt_symmetric($ctx, $pack_data, $pack_key, sub {
				push @{$_[0]}, ('--output', File::Spec->catfile($ctx->{'dir-cache'}, $pack_id));
				return @_;
			 });
			push @{$ctx->{remote}->{push}}, $pack_id;
			$ctx->{manifest}->{packs}->{$pack_id} =
			 { deps => [keys %pack_deps]
			 , hash => $pack_hash
			 , hash_algo => $ctx->{config}->{'pack-hash-algo'}
			 , key => $pack_key
			 , objects => \@pack_objects
			 };
		 }
	 }
# grg manifest
	sub grg_manifest_fetch ($) {
		my ($ctx) = @_;
		$ctx->{manifest} =
		 { 'hidden-keys' => {}
		 , keys => {}
		 , packs => {}
		 , refs => {}
		 , version => undef
		 };
		my $fetched = grg_remote_fetch($ctx, [$ctx->{'manifest-file'}]);
		my $crypt = $fetched->{$ctx->{'manifest-file'}}->{path};
		if (defined $crypt) {
			$ctx->{remote}->{checked} = 1;
			my $json;
			grg_decrypt_asymmetric($ctx, sub {
				push @{$_[0]}, $crypt;
				return (@_, '>', \$json); });
			rm($fetched->{$ctx->{'manifest-file'}}->{path})
				unless $fetched->{$ctx->{'manifest-file'}}->{preserve};
			my $manifest;
			($manifest = JSON::decode_json($json) and ref $manifest eq 'HASH')
				or error("failed to decode JSON manifest");
			$ctx->{manifest} = {%{$ctx->{manifest}}, %$manifest};
			foreach my $slot (qw(keys hidden-keys)) {
				while (my ($fpr, $uid) = each %{$ctx->{manifest}->{$slot}}) {
					my %keys = gpg_fingerprint($ctx, '0x'.$fpr, ['E']);
					my ($fpr, $uid) = each %keys;
					$ctx->{config}->{$slot}->{$fpr} = $uid;
				 }
			 }
		 }
		else {
			debug(sub{'ctx='}, $ctx);
			if ($ctx->{command} eq 'push' or $ctx->{command} eq 'list for-push') {
				$ctx->{remote}->{checked} = 0;
			 }
			elsif ($ctx->{remote}->{checking}) {
				exit 100;
			 }
			else {
				error("remote checking failed");
			 }
		 }
	 }
	sub grg_manifest_push ($) {
		my ($ctx) = @_;
		foreach my $slot (qw(keys hidden-keys)) {
			$ctx->{manifest}->{$slot} = {};
			while (my ($fpr, $uid) = each %{$ctx->{config}->{$slot}}) {
				$ctx->{manifest}->{$slot}->{$fpr} = $uid;
			 }
		 }
		my $json = JSON::encode_json($ctx->{manifest})
			or error("failed to encode JSON manifest");
		grg_encrypt_asymmetric($ctx, $json, sub {
			push @{$_[0]}
			 , ('--output', File::Spec->catfile($ctx->{'dir-cache'}, $ctx->{'manifest-file'}));
			return @_; });
		push @{$ctx->{remote}->{push}}, $ctx->{'manifest-file'};
	 }
# grg config
	sub grg_config_read($) {
		my ($ctx) = @_;
		my $cfg = $ctx->{config};
		local $/ = "\n";
		
		foreach my $name (qw(gpg signingkey keys)
		 , grep {       !m/^(gpg|signingkey|keys)$/ } (keys %$cfg)) {
			my $value;
			IPC::Run::run(['git', 'config', '--get', 'remote.'.$ctx->{remote}->{name}.'.'.$name, '.+'], '>', \$value) or
			IPC::Run::run(['git', 'config', '--get', 'grg.'.$name, '.+'], '>', \$value) or 1;
			if ($name eq 'signingkey') {
				IPC::Run::run(['git', 'config', '--get', 'user.'.$name, '.+'], '>', \$value)
					if (not $value);
				chomp $value;
				my %keys = gpg_fingerprint($ctx, $value, ['S']);
				warning("signing key ID is not matching a unique key: taking only one")
					unless scalar(keys %keys) == 1;
				my ($fpr, $uid) = each %keys;
				$cfg->{$name} = {fpr => $fpr, uid => $uid};
			 }
			elsif ($name eq 'keys' or $name eq 'hidden-keys') {
				IPC::Run::run(['git', 'config', '--get', 'user.'.$name, '.+'], '>', \$value)
					if (not $value);
				chomp $value;
				my @ids = split(/,/, $value);
				if (@ids > 0) {
					foreach my $key (@ids) {
						my %keys = gpg_fingerprint($ctx, $key, ['E']);
						while (my ($fpr, $uid) = each %keys) {
							$cfg->{$name}->{$fpr} = $uid;
						 }
					 }
				 }
			 }
			elsif (grep(/^$name$/, qw(curl gpg rsync))) {
				IPC::Run::run(['git', 'config', '--get', $name.'.program', '.+'], '>', \$value)
					if (not $value);
				$cfg->{$name} = [split(' ', $value)]
					if $value;
			 }
			else {
				chomp $value;
				$cfg->{$name} = $value
					if $value;
			 }
		 }
		error("no signingkey configured; to do so you may use one of following commands:\n"
		 , "\t\$ git config remote.'$ctx->{remote}->{name}'.signingkey \$your_openpgp_id\n"
		 , "\t\$ git config grg.signingkey \$your_openpgp_id\n"
		 , "\t\$ git config user.signingkey \$your_openpgp_id"
		 ) unless defined $cfg->{signingkey};
		if ( (scalar (keys %{$cfg->{keys}}) == 0)
		 and (scalar (keys %{$cfg->{'hidden-keys'}}) == 0) ) {
			$cfg->{keys} = { $cfg->{signingkey}->{fpr} => $cfg->{signingkey}->{uid} };
		 }
		
		debug(sub{'config='},$cfg);
	 }
# grg system
	sub grg_connect ($) {
		my ($ctx) = @_;
		grg_config_read($ctx);
		grg_manifest_fetch($ctx);
	 }
	sub grg_disconnect ($) {
		my ($ctx) = @_;
		grg_remote_push($ctx);
	 }
# grg commands
	sub gpg_command_answer ($) {
		my @cmd = @_;
		debug(sub{join('', @cmd)."\n"});
		print STDOUT (@cmd, "\n");
	 }
	sub grg_command_capabilities ($) {
		my ($ctx) = @_;
		$ctx->{command} = 'capabilities';
		gpg_command_answer("fetch");
		gpg_command_answer("push");
		gpg_command_answer("");
		STDOUT->flush;
	 }
	sub grg_command_fetch ($$) {
		my ($ctx, $fetch_refs) = @_;
		$ctx->{command} = 'fetch';
		debug(sub{"fetch_refs="}, $fetch_refs);
		grg_connect($ctx);
		# @fetch_objects
			my @fetch_objects= ();
			foreach my $ref (@$fetch_refs) {
				push @fetch_objects, $ref->{sha1};
			 }
		grg_pack_fetch($ctx, \@fetch_objects);
	 }
	sub grg_command_list ($$) {
		my ($ctx, $command) = @_;
		$ctx->{command} = $command;
		grg_connect($ctx);
		while (my ($ref, $obj) = each %{$ctx->{manifest}->{refs}}) {
			gpg_command_answer("$obj $ref");
		 };
		gpg_command_answer("");
	 }
	sub grg_command_push ($$) {
		my ($ctx, $push_refs) = @_;
		local $_;
		$ctx->{command} = 'push';
		debug(sub{"push_refs="}, $push_refs);
		grg_connect($ctx);
		# @push_objects
			my @push_objects= ();
			foreach my $ref (@$push_refs) {
				IPC::Run::run(['git', 'rev-list', '--ignore-missing', '--max-count=1', $ref->{src}, '--']
				 , '>', \$_)
					or error("failed to dereference ref to push: ".$ref->{src});
				chomp;
				$ref->{src_obj} = $_;
				push @push_objects, $_;
			 }
		grg_pack_push($ctx, \@push_objects);
		my $manifest_refs = $ctx->{manifest}->{refs};
		foreach my $ref (@$push_refs) {
			$manifest_refs->{$ref->{dst}} = $ref->{src_obj};
		 }
		$manifest_refs->{HEAD}
		 = $push_refs->[-1]->{src_obj}
			unless exists $manifest_refs->{HEAD}
			or @$push_refs == 0;
		grg_manifest_push($ctx);
		grg_disconnect($ctx);
	 }
	sub grg_commands(@) {
		my ($ctx) = @_;
		my $line = undef;
		local $/ = "\n";
		#STDOUT->autoflush(1);
		while (defined $line or (not eof(*STDIN) and
			(defined($line = readline(*STDIN)))
			 ? (chomp $line or 1)
			 : error("readline failed: $!")
		 )) {
			debug(sub{"line=\"",$line,"\"\n"});
			$ctx->{command} = undef;
			if ($line eq 'capabilities') {
				grg_command_capabilities($ctx);
				$line = undef;
			 }
			elsif ($line =~ m/^fetch .*$/) {
				my @refs = ();
				my ($sha1, $name);
				while ((defined $line or (not eof(*STDIN) and
					((defined($line = readline(*STDIN)))
					 ? (chomp $line or 1)
					 : error("readline failed: $!")))) and
					(($sha1, $name) = ($line =~ m/^fetch ([0-9a-f]{40}) (.+)$/))
				 ) {
					debug(sub{"fetch line=\"",$line,"\"\n"});
					push @refs, {sha1=>$sha1, name=>$name};
					$line = undef;
				 }
				error("failed to parse command: $line")
					if @refs == 0;
				grg_command_fetch($ctx, \@refs);
			 }
			elsif ($line eq 'list' or $line eq 'list for-push') {
				grg_command_list($ctx, $line);
				$line = undef;
			 }
			elsif ($line =~ m/^push .*$/) {
				my @refs = ();
				my ($force, $src, $dst);
				while ((defined $line or (not eof(*STDIN) and
					((defined($line = readline(*STDIN)))
					 ? (chomp $line or 1)
					 : error("readline failed: $!")))) and
					(($force, $src, $dst) = ($line =~ m/^push (\+)?([^:]+):(.+)$/))
				 ) {
					debug(sub{"push line=\"",$line,"\"\n"});
					push @refs, {force=>(defined $force), src=>$src, dst=>$dst};
					$line = undef;
				 }
				error("failed to parse command: $line")
					if @refs == 0;
				grg_command_push($ctx, \@refs);
			 }
			elsif ($line =~ m/^$/) {
				$line = undef;
				{
					local $SIG{'PIPE'} = 'IGNORE';
					gpg_command_answer("");
				}
				return 0;
			 }
			else {
				warning("unsupported command supplied: `$line'");
				$line = undef;
			 }
		 }
	 }
sub main {
	$ENV{GIT_DIR} = $ENV{GIT_DIR} || '.git';
	$ENV{GITCEPTION} = ($ENV{GITCEPTION} || '') . '+';
	my $ctx =
	 { command => undef
	 , config =>
		 { curl => ['curl']
		 , gpg => ['gpg']
		 , keys => {}
		 , 'hidden-keys' => {}
		 , 'manifest-hash-algo' => 'SHA224' # NOTE: SHA512, SHA384, SHA256, SHA224 supported.
		 , 'pack-filename-size' => 42
		 , 'pack-hash-algo' => 'SHA224' # NOTE: SHA512, SHA384, SHA256, SHA224 supported.
		 , 'pack-key-size' => 64
		 , signingkey => undef
		 , rsync => ['rsync']
		 }
	 , 'dir-cache' => undef
	 , manifest => {}
	 , 'manifest-file' => undef
	 , remote =>
		 { checking => 0
		 , checked => undef
		 , name => undef
		 , uri => undef
		 , push => []
		 }
	 };
	Getopt::Long::Configure
	 ( 'auto_version'
	 , 'pass_through'
	 , 'require_order'
	 );
	Getopt::Long::GetOptions
	 ( help => sub { Pod::Usage::pod2usage
		 ( -exitstatus => 0
		 , -sections   => ['SYNOPSIS', 'OPTIONS', 'REMOTES', 'CONFIG']
		 , -verbose    => 99 ); }
	 , man => sub { Pod::Usage::pod2usage(-verbose => 2); }
	 , check => sub {
			$ctx->{remote}->{checking} = 1;
		 }
	 );
	if (not $ctx->{remote}->{checking}) {
		my $name = shift @ARGV;
		Pod::Usage::pod2usage(-verbose => 1)
			unless defined $name;
		($ctx->{remote}->{name}) = ($name =~ m/^((\w|-)+)$/);
		error("valid name of remote Git required, got: `$name'")
			unless $ctx->{remote}->{name};
	 }
	my $uri = shift @ARGV;
	Pod::Usage::pod2usage(-verbose => 1)
		unless defined $uri;
	$ctx->{remote}->{uri} = URI->new($uri);
	error("valid URL of remote Git required, got: `$uri'")
		unless $ctx->{remote}->{uri};
	my $fragment = $ctx->{remote}->{uri}->fragment;
	$fragment = ''
		unless defined $fragment;
	$ctx->{'manifest-file'} = grg_hash($ctx
	 , $ctx->{config}->{'manifest-hash-algo'}
	 , sub { return (@_, '<', \$fragment); });
	if (-d $ENV{GIT_DIR}) {
		$ctx->{'dir-cache'} = File::Spec->catdir
		 ( $ENV{GIT_DIR}, 'cache', 'remotes'
		 , $ctx->{remote}->{name}, 'gpg');
		&mkdir($ctx->{'dir-cache'});
	 }
	else {
		$ctx->{'dir-cache'} = File::Temp->tempdir(CLEANUP => 1);
	 }
	debug(sub{"ctx="},$ctx);
	grg_commands($ctx);
 }
main;
1;
__END__

=encoding utf8

=head1 NAME

git-remote-gpg - git-remote-helpers(1) to encrypt remote repository through gpg(1)

=head1 SYNOPSIS

=item git-remote-gpg $gpg_remote $gpg_url

=item git-remote-gpg --check $gpg_url

=head1 OPTIONS

=over 8

=item B<-h>, B<--help>

=item B<--version>

=back

=head1 REMOTES

=head2 Via rsync(1)

=item git remote add $remote gpg::rsync://${user:+$user@}$host/$path

=head2 Via curl(1)

=item git remote add $remote gpg::sftp://${user:+$user@}$host/$path

=head2 Via File::Copy(3pm)

=item git remote add $remote gpg::file://$path

=head1 CONFIG

=head2 git-config(1)

=over 8

=item B<grg.curl>

=item B<grg.gpg>

=item B<grg.keys>

=item B<grg.hidden-keys>

=item B<grg.manifest-hash-algo>

=item B<grg.pack-filename-size>

=item B<grg.pack-hash-algo>

=item B<grg.pack-key-size>

=item B<grg.signingkey>

=item B<grg.rsync>

=back

=cut