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::Util qw(:class);
  11 use File::KDBX;
  12 use IO::Handle;
  13 use Module::Load;
  14 use Ref::Util qw(is_ref is_scalarref);
  15 use Scalar::Util qw(looks_like_number openhandle);
  16 use namespace::clean;
  17
  18 our $VERSION = '999.999'; # VERSION
  19
  20 =method new
  21
  22     $dumper = File::KDBX::Dumper->new(%attributes);
  23
  24 Construct a new L<File::KDBX::Dumper>.
  25
  26 =cut
  27
  28 sub new {
  29     my $class = shift;
  30     my $self = bless {}, $class;
  31     $self->init(@_);
  32 }
  33
  34 =method init
  35
  36     $dumper = $dumper->init(%attributes);
  37
  38 Initialize a L<File::KDBX::Dumper> with a new set of attributes.
  39
  40 This is called by L</new>.
  41
  42 =cut
  43
  44 sub init {
  45     my $self = shift;
  46     my %args = @_;
  47
  48     @$self{keys %args} = values %args;
  49
  50     return $self;
  51 }
  52
  53 sub _rebless {
  54     my $self    = shift;
  55     my $format  = shift // $self->format;
  56
  57     my $version = $self->kdbx->version;
  58
  59     my $subclass;
  60
  61     if (defined $format) {
  62         $subclass = $format;
  63     }
  64     elsif (!defined $version) {
  65         $subclass = 'XML';
  66     }
  67     elsif ($self->kdbx->sig2 == KDBX_SIG2_1) {
  68         $subclass = 'KDB';
  69     }
  70     elsif (looks_like_number($version)) {
  71         my $major = $version & KDBX_VERSION_MAJOR_MASK;
  72         my %subclasses = (
  73             KDBX_VERSION_2_0()  => 'V3',
  74             KDBX_VERSION_3_0()  => 'V3',
  75             KDBX_VERSION_4_0()  => 'V4',
  76         );
  77         if ($major == KDBX_VERSION_2_0) {
  78             alert sprintf("Upgrading KDBX version %x to version %x\n", $version, KDBX_VERSION_3_1);
  79             $self->kdbx->version(KDBX_VERSION_3_1);
  80         }
  81         $subclass = $subclasses{$major}
  82             or throw sprintf('Unsupported KDBX file version: %x', $version), version => $version;
  83     }
  84     else {
  85         throw sprintf('Unknown file version: %s', $version), version => $version;
  86     }
  87
  88     load "File::KDBX::Dumper::$subclass";
  89     bless $self, "File::KDBX::Dumper::$subclass";
  90 }
  91
  92 =method reset
  93
  94     $dumper = $dumper->reset;
  95
  96 Set a L<File::KDBX::Dumper> to a blank state, ready to dump another KDBX file.
  97
  98 =cut
  99
 100 sub reset {
 101     my $self = shift;
 102     %$self = ();
 103     return $self;
 104 }
 105
 106 =method dump
 107
 108     $dumper->dump(\$string, %options);
 109     $dumper->dump(\$string, $key, %options);
 110     $dumper->dump(*IO, %options);
 111     $dumper->dump(*IO, $key, %options);
 112     $dumper->dump($filepath, %options);
 113     $dumper->dump($filepath, $key, %options);
 114
 115 Dump a KDBX file.
 116
 117 The C<$key> is either a L<File::KDBX::Key> or a primitive castable to a Key object. Available options:
 118
 119 =for :list
 120 * C<kdbx> - Database to dump (default: value of L</kdbx>)
 121 * C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
 122
 123 Other options are supported depending on the first argument. See L</dump_string>, L</dump_file> and
 124 L</dump_handle>.
 125
 126 =cut
 127
 128 sub dump {
 129     my $self = shift;
 130     my $dst  = shift;
 131     return $self->dump_handle($dst, @_) if openhandle($dst);
 132     return $self->dump_string($dst, @_) if is_scalarref($dst);
 133     return $self->dump_file($dst, @_)   if defined $dst && !is_ref($dst);
 134     throw 'Programmer error: Must pass a stringref, filepath or IO handle to dump';
 135 }
 136
 137 =method dump_string
 138
 139     $dumper->dump_string(\$string, %options);
 140     $dumper->dump_string(\$string, $key, %options);
 141     \$string = $dumper->dump_string(%options);
 142     \$string = $dumper->dump_string($key, %options);
 143
 144 Dump a KDBX file to a string / memory buffer. Available options:
 145
 146 =for :list
 147 * C<kdbx> - Database to dump (default: value of L</kdbx>)
 148 * C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
 149
 150 =cut
 151
 152 sub dump_string {
 153     my $self = shift;
 154     my $ref  = is_scalarref($_[0]) ? shift : undef;
 155     my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
 156
 157     my $key = delete $args{key};
 158     $args{kdbx} //= $self->kdbx;
 159
 160     $ref //= do {
 161         my $buf = '';
 162         \$buf;
 163     };
 164
 165     open(my $fh, '>', $ref) or throw "Failed to open string buffer: $!";
 166
 167     $self = $self->new if !ref $self;
 168     $self->init(%args, fh => $fh)->_dump($fh, $key);
 169
 170     return $ref;
 171 }
 172
 173 =method dump_file
 174
 175     $dumper->dump_file($filepath, %options);
 176     $dumper->dump_file($filepath, $key, %options);
 177
 178 Dump a KDBX file to a filesystem. Available options:
 179
 180 =for :list
 181 * C<kdbx> - Database to dump (default: value of L</kdbx>)
 182 * C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
 183 * C<mode> - File mode / permissions (see L<perlfunc/"chmod LIST">
 184 * C<uid> - User ID (see L<perlfunc/"chown LIST">)
 185 * C<gid> - Group ID (see L<perlfunc/"chown LIST">)
 186 * C<atomic> - Write to the filepath atomically (default: true)
 187
 188 =cut
 189
 190 sub dump_file {
 191     my $self     = shift;
 192     my $filepath = shift;
 193     my %args     = @_ % 2 == 0 ? @_ : (key => shift, @_);
 194
 195     my $key     = delete $args{key};
 196     my $mode    = delete $args{mode};
 197     my $uid     = delete $args{uid};
 198     my $gid     = delete $args{gid};
 199     my $atomic  = delete $args{atomic} // 1;
 200
 201     $args{kdbx} //= $self->kdbx;
 202
 203     my ($fh, $filepath_temp);
 204     if ($atomic) {
 205         require File::Temp;
 206         ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", UNLINK => 1) };
 207         if (!$fh or my $err = $@) {
 208             $err //= 'Unknown error';
 209             throw sprintf('Open file failed (%s): %s', $filepath_temp, $err),
 210                 error       => $err,
 211                 filepath    => $filepath_temp;
 212         }
 213     }
 214     else {
 215         open($fh, '>:raw', $filepath) or throw "Open file failed ($filepath): $!", filepath => $filepath;
 216     }
 217     $fh->autoflush(1);
 218
 219     $self = $self->new if !ref $self;
 220     $self->init(%args, fh => $fh, filepath => $filepath);
 221     $self->_dump($fh, $key);
 222     close($fh);
 223
 224     my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
 225
 226     if ($filepath_temp) {
 227         $mode //= $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
 228         $uid  //= $file_uid  // -1;
 229         $gid  //= $file_gid  // -1;
 230         chmod($mode, $filepath_temp) if defined $mode;
 231         chown($uid, $gid, $filepath_temp);
 232         rename($filepath_temp, $filepath) or throw "Failed to write file ($filepath): $!",
 233             filepath => $filepath;
 234     }
 235
 236     return $self;
 237 }
 238
 239 =method dump_handle
 240
 241     $dumper->dump_handle($fh, %options);
 242     $dumper->dump_handle(*IO, $key, %options);
 243     $dumper->dump_handle($fh, %options);
 244     $dumper->dump_handle(*IO, $key, %options);
 245
 246 Dump a KDBX file to an output stream / file handle. Available options:
 247
 248 =for :list
 249 * C<kdbx> - Database to dump (default: value of L</kdbx>)
 250 * C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
 251
 252 =cut
 253
 254 sub dump_handle {
 255     my $self = shift;
 256     my $fh   = shift;
 257     my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
 258
 259     $fh = *STDOUT if $fh eq '-';
 260
 261     my $key = delete $args{key};
 262     $args{kdbx} //= $self->kdbx;
 263
 264     $self = $self->new if !ref $self;
 265     $self->init(%args, fh => $fh)->_dump($fh, $key);
 266 }
 267
 268 =attr kdbx
 269
 270     $kdbx = $dumper->kdbx;
 271     $dumper->kdbx($kdbx);
 272
 273 Get or set the L<File::KDBX> instance with the data to be dumped.
 274
 275 =cut
 276
 277 sub kdbx {
 278     my $self = shift;
 279     return File::KDBX->new if !ref $self;
 280     $self->{kdbx} = shift if @_;
 281     $self->{kdbx} //= File::KDBX->new;
 282 }
 283
 284 =attr format
 285
 286 Get the file format used for writing the database. Normally the format is auto-detected from the database,
 287 which is the safest choice. Possible formats:
 288
 289 =for :list
 290 * C<V3>
 291 * C<V4>
 292 * C<KDB>
 293 * C<XML> (only used if explicitly set)
 294 * C<Raw> (only used if explicitly set)
 295
 296 B<WARNING:> There is a potential for data loss if you explicitly use a format that doesn't support the
 297 features used by the KDBX database being written.
 298
 299 The most common reason to explicitly specify the file format is to save a database as an unencrypted XML file:
 300
 301     $kdbx->dump_file('database.xml', format => 'XML');
 302
 303 =attr inner_format
 304
 305 Get the format of the data inside the KDBX envelope. This only applies to C<V3> and C<V4> formats. Possible
 306 formats:
 307
 308 =for :list
 309 * C<XML> - Write the database groups and entries as XML (default)
 310 * C<Raw> - Write L<File::KDBX/raw> instead of the actual database contents
 311
 312 =attr allow_upgrade
 313
 314     $bool = $dumper->allow_upgrade;
 315
 316 Whether or not to allow implicitly upgrading a database to a newer version. When enabled, in order to avoid
 317 potential data loss, the database can be upgraded as-needed in cases where the database file format version is
 318 too low to support new features being used.
 319
 320 The default is to allow upgrading.
 321
 322 =attr randomize_seeds
 323
 324     $bool = $dumper->randomize_seeds;
 325
 326 Whether or not to randomize seeds in a database before writing. The default is to randomize seeds, and there's
 327 not often a good reason not to do so. If disabled, the seeds associated with the KDBX database will be used as
 328 they are.
 329
 330 =cut
 331
 332 has 'format',           is => 'ro';
 333 has 'inner_format',     is => 'ro', default => 'XML';
 334 has 'allow_upgrade',    is => 'ro', default => 1;
 335 has 'randomize_seeds',  is => 'ro', default => 1;
 336
 337 sub _fh { $_[0]->{fh} or throw 'IO handle not set' }
 338
 339 sub _dump {
 340     my $self = shift;
 341     my $fh = shift;
 342     my $key = shift;
 343
 344     my $kdbx = $self->kdbx;
 345
 346     my $min_version = $kdbx->minimum_version;
 347     if ($kdbx->version < $min_version && $self->allow_upgrade) {
 348         alert sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version),
 349             version => $kdbx->version, min_version => $min_version;
 350         $kdbx->version($min_version);
 351     }
 352     $self->_rebless;
 353
 354     if (ref($self) =~ /::(?:KDB|V[34])$/) {
 355         $key //= $kdbx->key ? $kdbx->key->reload : undef;
 356         defined $key or throw 'Must provide a master key', type => 'key.missing';
 357     }
 358
 359     $self->_prepare;
 360
 361     my $magic = $self->_write_magic_numbers($fh);
 362     my $headers = $self->_write_headers($fh);
 363
 364     $kdbx->unlock;
 365
 366     $self->_write_body($fh, $key, "$magic$headers");
 367
 368     return $kdbx;
 369 }
 370
 371 sub _prepare {
 372     my $self = shift;
 373     my $kdbx = $self->kdbx;
 374
 375     if ($kdbx->version < KDBX_VERSION_4_0) {
 376         # force Salsa20 inner random stream
 377         $kdbx->inner_random_stream_id(STREAM_ID_SALSA20);
 378         my $key = $kdbx->inner_random_stream_key;
 379         substr($key, 32) = '';
 380         $kdbx->inner_random_stream_key($key);
 381     }
 382
 383     $kdbx->randomize_seeds if $self->randomize_seeds;
 384 }
 385
 386 sub _write_magic_numbers {
 387     my $self = shift;
 388     my $fh = shift;
 389
 390     my $kdbx = $self->kdbx;
 391
 392     $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', sig1 => $kdbx->sig1;
 393     $kdbx->version < KDBX_VERSION_OLDEST || KDBX_VERSION_LATEST < $kdbx->version
 394         and throw 'Unsupported file version', version => $kdbx->version;
 395
 396     my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version);
 397
 398     my $buf = pack('L<3', @magic);
 399     $fh->print($buf) or throw 'Failed to write file signature';
 400
 401     return $buf;
 402 }
 403
 404 sub _write_headers { die "Not implemented" }
 405
 406 sub _write_body { die "Not implemented" }
 407
 408 sub _write_inner_body {
 409     my $self = shift;
 410
 411     my $current_pkg = ref $self;
 412     require Scope::Guard;
 413     my $guard = Scope::Guard->new(sub { bless $self, $current_pkg });
 414
 415     $self->_rebless($self->inner_format);
 416     $self->_write_inner_body(@_);
 417 }
 418
 419 1;