filetomb.pl

#!/usr/bin/env perl

use v5.14;
use Ask                      qw( error warning info question );
use Crypt::Cipher::Blowfish  qw();
use Crypt::Mode::CBC         qw();
use Crypt::PK::DSA           qw();
use Getopt::Long             qw(GetOptions);
use MIME::Base64::URLSafe    qw(urlsafe_b64encode urlsafe_b64decode);
use Path::Tiny               qw(path);
use Pod::Usage               qw(pod2usage);

my ($mode, $private, $public);
my $tomb = path($ENV{HOME}, 'Documents/Tomb/Archive')->absolute;

GetOptions(
	'tomb'             => \$tomb,
	'private'          => \$private,
	'public'           => \$public,
	'archive|store|a'  => sub { $mode = 'a' },
	'retrieve|r'       => sub { $mode = 'r' },
	'help|usage|h'     => sub { pod2usage(1); exit; },
);

for ($tomb, $private, $public)
{
	next unless defined;
	$_ = path($_)->absolute;
}

defined($mode)
	or error("Please specify --archive or --retrieve mode on command line!") && die;

my $dsa = Crypt::PK::DSA->new;
if ( $private && $private->exists )
{
	$dsa->import_key("$private");
}
elsif ( $public && $public->exists )
{
	error("Cannot decrypt without a private key") && die if $mode eq 'r';
	$dsa->import_key("$public");
}
else
{
	my $default_public  = path($ENV{HOME}, 'Documents/Tomb/Public.key')->absolute;
	my $default_private = path($ENV{HOME}, 'Documents/Tomb/Private.key')->absolute;
		
	if ( $default_private->exists )
	{
		warning("No keys specified - falling back to '$default_private'");
		$dsa->import_key("$default_private");
	}
	elsif ( $default_public->exists )
	{
		warning("No keys specified - falling back to '$default_public'");
		error("Cannot decrypt without a private key") && die if $mode eq 'r';
		$dsa->import_key("$default_public");
	}
	else
	{
		warning("No keys specified - generating new key pair as '$default_private' and '$default_public'");
		$dsa->generate_key(20, 128);
		$default_private->parent->mkpath;
		$default_private->spew( $dsa->export_key_der("private") );
		$default_public->spew( $dsa->export_key_der("public") );
	}
}

@ARGV or error("Requires input file name!") && die;

while (@ARGV)
{
	my $file = path(shift)->absolute;
	
	my $tombfile = do {
		my $blowfish = Crypt::Mode::CBC->new('Blowfish');
		my $key = substr($dsa->export_key_der('private'), 0, Crypt::Cipher::Blowfish->min_keysize);
		my $enc = $blowfish->encrypt("$file", $key, '12345678');
		$tomb->child(sprintf '%s.tomb', urlsafe_b64encode($enc));
	};
	
	if ($mode eq 'a') # archive
	{
		$tombfile->parent->mkpath;
		
		$file->exists or error("Cannot archive a non-existant file!") && die;
		$tombfile->spew($dsa->encrypt($file->slurp));
		info("'$file' archived as '$tombfile'");
	}
	
	else # retrieve
	{
		$tombfile->exists or error("Tomb $tombfile not found!") && die;
		
		if ($file->exists)
		{
			die unless question("Really overwrite $file???");
		}
		
		info("Retrieving '$file' from '$tombfile'");
		$file->spew($dsa->decrypt($tombfile->slurp));
	}
}

__END__

=pod

=encoding utf-8

=head1 NAME

filetomb - archive files into an encrypted tomb

=head1 SYNPOSIS

filetomb [options] filename...

 Options:
   --archive, -a      Archive mode
   --retrieve, -r     Retrieve mode
   --public=FILE      Path to public key
   --private=FILE     Path to private key
   --tomb=DIR         Path to tomb

=head1 DESCRIPTION

To store a file:

 $ ls -l 'bomb-plot.txt'
 -rw-rw-r-- 1 tai tai 12 Oct 17 10:57 bomb-plot.txt
 $ filetomb -a "bomb-plot.txt";
 'bomb-plot.txt' archived as '12345678.tomb'
 $ rm -f "bomb-plot.txt";
 $ ls -l 'bomb-plot.txt'
 ls: cannot access bomb-plot.txt: No such file or directory

To retrieve the file:

 $ ls -l 'bomb-plot.txt'
 ls: cannot access bomb-plot.txt: No such file or directory
 $ filetomb -r 'bomb-plot.txt'
 Retrieving 'bomb-plot.txt' from '12345678.tomb'
 $ ls -l 'bomb-plot.txt'
 -rw-rw-r-- 1 tai tai 12 Oct 17 10:57 bomb-plot.txt

Easy-peasy, right?

Generally speaking, you want to keep all your files in the same tomb
directory (the C<< --tomb >> option), and keep that backed up, perhaps
using a version control system.

Unless you specify keys for encryption, filetomb will use a default key
pair stored in a well-known location.

=head1 AUTHOR

Toby Inkster E<lt>tobyink@cpan.orgE<gt>.

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2013 by Toby Inkster.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=head1 DISCLAIMER OF WARRANTIES

THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.