Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Dumper.pm

   1 package File::KDBX::Dumper;
   2 # ABSTRACT: Write KDBX files
   3
   4 use warnings;
   5 use strict;
   6
   7 use Crypt::Digest qw(digest_data);
   8 use File::KDBX::Constants qw(:magic :header :version :random_stream);
   9 use File::KDBX::Error;
  10 use File::KDBX;
  11 use IO::Handle;
  12 use Module::Load;
  13 use Ref::Util qw(is_ref is_scalarref);
  14 use Scalar::Util qw(looks_like_number openhandle);
  15 use namespace::clean;
  16
  17 our $VERSION = '999.999'; # VERSION
  18
  19 =method new
  20
  21     $dumper = File::KDBX::Dumper->new(%attributes);
  22
  23 Construct a new L<File::KDBX::Dumper>.
  24
  25 =cut
  26
  27 sub new {
  28     my $class = shift;
  29     my $self = bless {}, $class;
  30     $self->init(@_);
  31 }
  32
  33 =method init
  34
  35     $dumper = $dumper->init(%attributes);
  36
  37 Initialize a L<File::KDBX::Dumper> with a new set of attributes.
  38
  39 This is called by L</new>.
  40
  41 =cut
  42
  43 sub init {
  44     my $self = shift;
  45     my %args = @_;
  46
  47     @$self{keys %args} = values %args;
  48
  49     return $self;
  50 }
  51
  52 sub _rebless {
  53     my $self    = shift;
  54     my $format  = shift // $self->format;
  55
  56     my $version = $self->kdbx->version;
  57
  58     my $subclass;
  59
  60     if (defined $format) {
  61         $subclass = $format;
  62     }
  63     elsif (!defined $version) {
  64         $subclass = 'XML';
  65     }
  66     elsif ($self->kdbx->sig2 == KDBX_SIG2_1) {
  67         $subclass = 'KDB';
  68     }
  69     elsif (looks_like_number($version)) {
  70         my $major = $version & KDBX_VERSION_MAJOR_MASK;
  71         my %subclasses = (
  72             KDBX_VERSION_2_0()  => 'V3',
  73             KDBX_VERSION_3_0()  => 'V3',
  74             KDBX_VERSION_4_0()  => 'V4',
  75         );
  76         if ($major == KDBX_VERSION_2_0) {
  77             alert sprintf("Upgrading KDBX version %x to version %x\n", $version, KDBX_VERSION_3_1);
  78             $self->kdbx->version(KDBX_VERSION_3_1);
  79         }
  80         $subclass = $subclasses{$major}
  81             or throw sprintf('Unsupported KDBX file version: %x', $version), version => $version;
  82     }
  83     else {
  84         throw sprintf('Unknown file version: %s', $version), version => $version;
  85     }
  86
  87     load "File::KDBX::Dumper::$subclass";
  88     bless $self, "File::KDBX::Dumper::$subclass";
  89 }
  90
  91 =method reset
  92
  93     $dumper = $dumper->reset;
  94
  95 Set a L<File::KDBX::Dumper> to a blank state, ready to dumper another KDBX file.
  96
  97 =cut
  98
  99 sub reset {
 100     my $self = shift;
 101     %$self = ();
 102     return $self;
 103 }
 104
 105 =method dump
 106
 107     $dumper->dump(\$string, $key);
 108     $dumper->dump(*IO, $key);
 109     $dumper->dump($filepath, $key);
 110
 111 Dump a KDBX file.
 112
 113 The C<$key> is either a L<File::KDBX::Key> or a primitive that can be converted to a Key object.
 114
 115 =cut
 116
 117 sub dump {
 118     my $self = shift;
 119     my $dst  = shift;
 120     return $self->dump_handle($dst, @_) if openhandle($dst);
 121     return $self->dump_string($dst, @_) if is_scalarref($dst);
 122     return $self->dump_file($dst, @_)   if defined $dst && !is_ref($dst);
 123     throw 'Programmer error: Must pass a stringref, filepath or IO handle to dump';
 124 }
 125
 126 =method dump_string
 127
 128     $dumper->dump_string(\$string, $key);
 129     \$string = $dumper->dump_string($key);
 130
 131 Dump a KDBX file to a string / memory buffer.
 132
 133 =cut
 134
 135 sub dump_string {
 136     my $self = shift;
 137     my $ref  = is_scalarref($_[0]) ? shift : undef;
 138     my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
 139
 140     my $key = delete $args{key};
 141     $args{kdbx} //= $self->kdbx;
 142
 143     $ref //= do {
 144         my $buf = '';
 145         \$buf;
 146     };
 147
 148     open(my $fh, '>', $ref) or throw "Failed to open string buffer: $!";
 149
 150     $self = $self->new if !ref $self;
 151     $self->init(%args, fh => $fh)->_dump($fh, $key);
 152
 153     return $ref;
 154 }
 155
 156 =method dump_file
 157
 158     $dumper->dump_file($filepath, $key);
 159
 160 Dump a KDBX file to a filesystem.
 161
 162 =cut
 163
 164 sub dump_file {
 165     my $self     = shift;
 166     my $filepath = shift;
 167     my %args     = @_ % 2 == 0 ? @_ : (key => shift, @_);
 168
 169     my $key = delete $args{key};
 170     $args{kdbx} //= $self->kdbx;
 171
 172     require File::Temp;
 173     my ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", CLEANUP => 1) };
 174     if (!$fh or my $err = $@) {
 175         $err //= 'Unknown error';
 176         throw sprintf('Open file failed (%s): %s', $filepath_temp, $err),
 177             error       => $err,
 178             filepath    => $filepath_temp;
 179     }
 180     $fh->autoflush(1);
 181
 182     $self = $self->new if !ref $self;
 183     $self->init(%args, fh => $fh, filepath => $filepath);
 184     $self->_dump($fh, $key);
 185     close($fh);
 186
 187     my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
 188
 189     my $mode = $args{mode} // $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
 190     my $uid  = $args{uid}  // $file_uid  // -1;
 191     my $gid  = $args{gid}  // $file_gid  // -1;
 192     chmod($mode, $filepath_temp) if defined $mode;
 193     chown($uid, $gid, $filepath_temp);
 194     rename($filepath_temp, $filepath) or throw "Failed to write file ($filepath): $!", filepath => $filepath;
 195
 196     return $self;
 197 }
 198
 199 =method dump_handle
 200
 201     $dumper->dump_handle($fh, $key);
 202     $dumper->dump_handle(*IO, $key);
 203
 204 Dump a KDBX file to an input stream / file handle.
 205
 206 =cut
 207
 208 sub dump_handle {
 209     my $self = shift;
 210     my $fh   = shift;
 211     my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
 212
 213     $fh = *STDOUT if $fh eq '-';
 214
 215     my $key = delete $args{key};
 216     $args{kdbx} //= $self->kdbx;
 217
 218     $self = $self->new if !ref $self;
 219     $self->init(%args, fh => $fh)->_dump($fh, $key);
 220 }
 221
 222 =attr kdbx
 223
 224     $kdbx = $dumper->kdbx;
 225     $dumper->kdbx($kdbx);
 226
 227 Get or set the L<File::KDBX> instance with the data to be dumped.
 228
 229 =cut
 230
 231 sub kdbx {
 232     my $self = shift;
 233     return File::KDBX->new if !ref $self;
 234     $self->{kdbx} = shift if @_;
 235     $self->{kdbx} //= File::KDBX->new;
 236 }
 237
 238 =attr format
 239
 240 =cut
 241
 242 sub format { $_[0]->{format} }
 243 sub inner_format { $_[0]->{inner_format} // 'XML' }
 244
 245 =attr min_version
 246
 247     $min_version = File::KDBX::Dumper->min_version;
 248
 249 Get the minimum KDBX file version supported, which is 3.0 or C<0x00030000> as
 250 it is encoded.
 251
 252 To generate older KDBX files unsupported by this module, try L<File::KeePass>.
 253
 254 =cut
 255
 256 sub min_version { KDBX_VERSION_OLDEST }
 257
 258 sub upgrade { $_[0]->{upgrade} // 1 }
 259
 260 sub randomize_seeds { $_[0]->{randomize_seeds} // 1 }
 261
 262 sub _fh { $_[0]->{fh} or throw 'IO handle not set' }
 263
 264 sub _dump {
 265     my $self = shift;
 266     my $fh = shift;
 267     my $key = shift;
 268
 269     my $kdbx = $self->kdbx;
 270
 271     my $min_version = $kdbx->minimum_version;
 272     if ($kdbx->version < $min_version && $self->upgrade) {
 273         alert sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version),
 274             version => $kdbx->version, min_version => $min_version;
 275         $kdbx->version($min_version);
 276     }
 277     $self->_rebless;
 278
 279     if (ref($self) =~ /::(?:KDB|V[34])$/) {
 280         $key //= $kdbx->key ? $kdbx->key->reload : undef;
 281         defined $key or throw 'Must provide a master key', type => 'key.missing';
 282     }
 283
 284     $self->_prepare;
 285
 286     my $magic = $self->_write_magic_numbers($fh);
 287     my $headers = $self->_write_headers($fh);
 288
 289     $kdbx->unlock;
 290
 291     $self->_write_body($fh, $key, "$magic$headers");
 292
 293     return $kdbx;
 294 }
 295
 296 sub _prepare {
 297     my $self = shift;
 298     my $kdbx = $self->kdbx;
 299
 300     if ($kdbx->version < KDBX_VERSION_4_0) {
 301         # force Salsa20 inner random stream
 302         $kdbx->inner_random_stream_id(STREAM_ID_SALSA20);
 303         my $key = $kdbx->inner_random_stream_key;
 304         substr($key, 32) = '';
 305         $kdbx->inner_random_stream_key($key);
 306     }
 307
 308     $kdbx->randomize_seeds if $self->randomize_seeds;
 309 }
 310
 311 sub _write_magic_numbers {
 312     my $self = shift;
 313     my $fh = shift;
 314
 315     my $kdbx = $self->kdbx;
 316
 317     $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', sig1 => $kdbx->sig1;
 318     $kdbx->version < $self->min_version || KDBX_VERSION_LATEST < $kdbx->version
 319         and throw 'Unsupported file version', version => $kdbx->version;
 320
 321     my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version);
 322
 323     my $buf = pack('L<3', @magic);
 324     $fh->print($buf) or throw 'Failed to write file signature';
 325
 326     return $buf;
 327 }
 328
 329 sub _write_headers { die "Not implemented" }
 330
 331 sub _write_body { die "Not implemented" }
 332
 333 sub _write_inner_body {
 334     my $self = shift;
 335
 336     my $current_pkg = ref $self;
 337     require Scope::Guard;
 338     my $guard = Scope::Guard->new(sub { bless $self, $current_pkg });
 339
 340     $self->_rebless($self->inner_format);
 341     $self->_write_inner_body(@_);
 342 }
 343
 344 1;