#### listing one (encryptor)
#!/usr/bin/perl -w
use strict;
$|++;

## begin config

my $SRC_ROOT = '/home/barney/webfiles';
my $GPG_HOME = '/home/barney/.publish-gpg';
my $GPG_PASSPHRASE = 'barneyphrase';
my $LOCALUSER = 'barney';
my $REMOTEUSER = 'fred';
my $EMAILTO = 'web-update@webhaus.comm';

## end config

use autouse 'Storable' => qw(store_fd retrieve_fd);
use autouse 'File::Spec::Functions' => qw(abs2rel rel2abs);

## set up pipeline
## generate object | encrypt | mailer

## first stage: generate object
unless (my $pid = open STDIN, "-|") {
  die "Can't fork: $!" unless defined $pid;

  my %payload;
  for (@ARGV) {
    local *F;
    my $abs = rel2abs($_);
    my $rel = abs2rel($abs, $SRC_ROOT);
    die "$abs is not below $SRC_ROOT" if $rel =~ m/\A\.\.(\/|\z)/s;
    open F, "<$abs" or die "cannot open $abs: $!";
    $payload{$rel} = {content => join("", <F>), mtime => (stat F)[9]};
  }

  store_fd \%payload, \*STDOUT;
  exit 0;
}

## second stage: encrypt
unless (my $pid = open STDIN, "-|") {
  die "Can't fork: $!" unless defined $pid;
  require GnuPG;
  GnuPG->new(homedir => $GPG_HOME)->
    encrypt(passphrase => $GPG_PASSPHRASE,
            recipient => $REMOTEUSER,
            'local-user' => $LOCALUSER,
            armor => 1, sign => 1);
  exit 0;
}

## third stage: send mail
exec "/bin/mail", $EMAILTO;     # punt :)
die "cannot exec /bin/mail: $!";
#### listing two (decryptor)
#!/usr/bin/perl -w
use strict;
$|++;

## begin config

my $DEST_ROOT = "/home/httpd/htdocs/";
my $LOGFILE = "/home/fred/lib/web-update.log";
my $GPG_HOME = "/home/fred/.publish-gpg"
my $GPG_PASSPHRASE = 'fredphrase';
my %ROLES = (
             ## barney:
             "80989563762BC0677D96542EFAA3AAF8282564B7" => ['html', 'gif'],
            );
my %AUTHS = (
  'images' => [sub { $_[1] =~ /^images\/.*\.(gif|jpe?g)$/ }],
  'editor' => [sub { $_[0] !~ /^\./ }],
  'html' => [sub { -f $_[2] and $_[0] !~ /^\./ and $_[0] =~ /\.html$/ }],
  'gif' => [sub { -f $_[2] and $_[0] !~ /^\./ and $_[0] =~ /\.gif$/ }],
);

## end config

use autouse 'Storable' => qw(store_fd retrieve_fd);
use autouse 'File::Spec::Functions' => qw(abs2rel rel2abs catfile);
use autouse 'File::Basename' => qw(fileparse);
use autouse 'File::Path' => qw(mkpath);

sub __stamp {
  my $message = shift;
  my(@now) = localtime;
  my $stamp = sprintf "[%d] [%02d@%02d:%02d:%02d] ",
    $$, @now[3,2,1,0];
  $message =~ s/^/$stamp/gm;
  $message;
}

$SIG{__WARN__} = sub { warn __stamp(shift) };
$SIG{__DIE__} = sub { die __stamp(shift) };

open STDOUT, ">>$LOGFILE" or die "Cannot append to $LOGFILE: $!";
open STDERR, ">&STDOUT";

## set up pipeline
## <message decrypt | processor (with secondary channel)

## establish secondary channel...
pipe FROM, TO or die "cannot pipe: $!";

## first stage: decrypt
unless (my $pid = open STDIN, "-|") {
  die "Can't fork: $!" unless defined $pid;

  close FROM;

  require GnuPG;
  my $h = GnuPG->new(homedir => $GPG_HOME)->
    decrypt(passphrase => $GPG_PASSPHRASE);

  if ($h and ref $h) {
    store_fd $h, \*TO;
  } else {
    store_fd {}, \*TO;
    warn $h ? "not signed\n" : "cannot decrypt\n";
  }

  close TO;

  exit 0;
}

## second stage: processor
close TO;

die "BAD PARENT RESPONSE, aborting" if eof(FROM);
my $h = retrieve_fd \*FROM;
close FROM;

die "failed validation" unless keys %$h;

## we've got validation, so fetch the payload
my $payload = retrieve_fd \*STDIN;

## TODO: record $h->{sigid} and reject duplicate as a replay attack
warn "processing an update from $h->{user}...\n";

my @auths = do {
  my $roles = $ROLES{$h->{fingerprint}}
    or die "No roles for $h->{fingerprint}";
  map {
    my $auths = $AUTHS{$_};
    $auths ? @$auths : ();
  } @$roles; # list of coderefs
};

my $prefix = time . ".$$.";

while (my($rel, $info) = each(%$payload)) {
  local *F;
  my $abs = rel2abs($rel, $DEST_ROOT);
  $rel = abs2rel($abs, $DEST_ROOT); # should be same as original $rel
  die "$abs is not below $DEST_ROOT" if $rel =~ m/\A\.\.(\/|\z)/s;
  my ($basename, $dirname) = fileparse($abs); # dirname ends in slash
  do {
    my $ok = 0;
    for (@auths) {
      last if $ok = $_->($basename, $rel, $abs, $dirname, $info);
    }
    $ok;
  } or warn("$rel: not authorized, skipping\n"), next;
  mkpath([$dirname], 0, 0755);
  -d $dirname or die "Missing $dirname";
  my $perms = 0644;             # default unless previous
  if (-e $abs) {
    my $mtime = (stat _)[9];
    $perms = (stat _)[2] & 0777; # previous perms
    if ((my $age = $mtime - $info->{mtime}) >= 0) {
      warn "$rel: skipping older file ($age seconds)\n";
      next;
    }

    my $attic = catfile($dirname, ".attic");
    mkpath([$attic], 0, 0755);
    -d $attic or die "Missing $attic";
    my $atticfile = catfile($attic, "$prefix$basename");
    link $abs, $atticfile or die "Cannot ln $abs $atticfile: $!";
    warn "$rel: previous saved in .attic/$prefix$basename\n";
  }
  {
    my $tmp = "$basename.$$";
    open F, ">$tmp" or die "Cannot create $tmp: $!";
    print F $info->{content};
    close F;
    chmod $perms, $tmp or warn "cannot chmod($perms,$tmp): $!";
    utime $info->{mtime}, $info->{mtime}, $tmp or
      warn "cannot set mtime on $tmp: $!\n";
    rename $tmp, $abs or die "Cannot mv $tmp $abs: $!";
  }
  warn "$rel: new version installed\n";
}