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, $key);
 109     $dumper->dump(*IO, $key);
 110     $dumper->dump($filepath, $key);
 111
 112 Dump a KDBX file.
 113
 114 The C<$key> is either a L<File::KDBX::Key> or a primitive that can be cast to a Key object.
 115
 116 =cut
 117
 118 sub dump {
 119     my $self = shift;
 120     my $dst  = shift;
 121     return $self->dump_handle($dst, @_) if openhandle($dst);
 122     return $self->dump_string($dst, @_) if is_scalarref($dst);
 123     return $self->dump_file($dst, @_)   if defined $dst && !is_ref($dst);
 124     throw 'Programmer error: Must pass a stringref, filepath or IO handle to dump';
 125 }
 126
 127 =method dump_string
 128
 129     $dumper->dump_string(\$string, $key);
 130     \$string = $dumper->dump_string($key);
 131
 132 Dump a KDBX file to a string / memory buffer.
 133
 134 =cut
 135
 136 sub dump_string {
 137     my $self = shift;
 138     my $ref  = is_scalarref($_[0]) ? shift : undef;
 139     my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
 140
 141     my $key = delete $args{key};
 142     $args{kdbx} //= $self->kdbx;
 143
 144     $ref //= do {
 145         my $buf = '';
 146         \$buf;
 147     };
 148
 149     open(my $fh, '>', $ref) or throw "Failed to open string buffer: $!";
 150
 151     $self = $self->new if !ref $self;
 152     $self->init(%args, fh => $fh)->_dump($fh, $key);
 153
 154     return $ref;
 155 }
 156
 157 =method dump_file
 158
 159     $dumper->dump_file($filepath, $key);
 160
 161 Dump a KDBX file to a filesystem.
 162
 163 =cut
 164
 165 sub dump_file {
 166     my $self     = shift;
 167     my $filepath = shift;
 168     my %args     = @_ % 2 == 0 ? @_ : (key => shift, @_);
 169
 170     my $key = delete $args{key};
 171     $args{kdbx} //= $self->kdbx;
 172
 173     require File::Temp;
 174     my ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", CLEANUP => 1) };
 175     if (!$fh or my $err = $@) {
 176         $err //= 'Unknown error';
 177         throw sprintf('Open file failed (%s): %s', $filepath_temp, $err),
 178             error       => $err,
 179             filepath    => $filepath_temp;
 180     }
 181     $fh->autoflush(1);
 182
 183     $self = $self->new if !ref $self;
 184     $self->init(%args, fh => $fh, filepath => $filepath);
 185     $self->_dump($fh, $key);
 186     close($fh);
 187
 188     my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
 189
 190     my $mode = $args{mode} // $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
 191     my $uid  = $args{uid}  // $file_uid  // -1;
 192     my $gid  = $args{gid}  // $file_gid  // -1;
 193     chmod($mode, $filepath_temp) if defined $mode;
 194     chown($uid, $gid, $filepath_temp);
 195     rename($filepath_temp, $filepath) or throw "Failed to write file ($filepath): $!", filepath => $filepath;
 196
 197     return $self;
 198 }
 199
 200 =method dump_handle
 201
 202     $dumper->dump_handle($fh, $key);
 203     $dumper->dump_handle(*IO, $key);
 204
 205 Dump a KDBX file to an output stream / file handle.
 206
 207 =cut
 208
 209 sub dump_handle {
 210     my $self = shift;
 211     my $fh   = shift;
 212     my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
 213
 214     $fh = *STDOUT if $fh eq '-';
 215
 216     my $key = delete $args{key};
 217     $args{kdbx} //= $self->kdbx;
 218
 219     $self = $self->new if !ref $self;
 220     $self->init(%args, fh => $fh)->_dump($fh, $key);
 221 }
 222
 223 =attr kdbx
 224
 225     $kdbx = $dumper->kdbx;
 226     $dumper->kdbx($kdbx);
 227
 228 Get or set the L<File::KDBX> instance with the data to be dumped.
 229
 230 =cut
 231
 232 sub kdbx {
 233     my $self = shift;
 234     return File::KDBX->new if !ref $self;
 235     $self->{kdbx} = shift if @_;
 236     $self->{kdbx} //= File::KDBX->new;
 237 }
 238
 239 =attr format
 240
 241 Get the file format used for writing the database. Normally the format is auto-detected from the database,
 242 which is the safest choice. Possible formats:
 243
 244 =for :list
 245 * C<V3>
 246 * C<V4>
 247 * C<KDB>
 248 * C<XML> (only used if explicitly set)
 249 * C<Raw> (only used if explicitly set)
 250
 251 B<WARNING:> There is a potential for data loss if you explicitly use a format that doesn't support the
 252 features used by the KDBX database being written.
 253
 254 The most common reason to explicitly specify the file format is to save a database as an unencrypted XML file:
 255
 256     $kdbx->dump_file('database.xml', format => 'XML');
 257
 258 =attr inner_format
 259
 260 Get the format of the data inside the KDBX envelope. This only applies to C<V3> and C<V4> formats. Possible
 261 formats:
 262
 263 =for :list
 264 * C<XML> - Write the database groups and entries as XML (default)
 265 * C<Raw> - Write L<File::KDBX/raw> instead of the actual database contents
 266
 267 =attr allow_upgrade
 268
 269     $bool = $dumper->allow_upgrade;
 270
 271 Whether or not to allow implicitly upgrading a database to a newer version. When enabled, in order to avoid
 272 potential data loss, the database can be upgraded as-needed in cases where the database file format version is
 273 too low to support new features being used.
 274
 275 The default is to allow upgrading.
 276
 277 =attr randomize_seeds
 278
 279     $bool = $dumper->randomize_seeds;
 280
 281 Whether or not to randomize seeds in a database before writing. The default is to randomize seeds, and there's
 282 not often a good reason not to do so. If disabled, the seeds associated with the KDBX database will be used as
 283 they are.
 284
 285 =cut
 286
 287 has 'format',           is => 'ro';
 288 has 'inner_format',     is => 'ro', default => 'XML';
 289 has 'allow_upgrade',    is => 'ro', default => 1;
 290 has 'randomize_seeds',  is => 'ro', default => 1;
 291
 292 sub _fh { $_[0]->{fh} or throw 'IO handle not set' }
 293
 294 sub _dump {
 295     my $self = shift;
 296     my $fh = shift;
 297     my $key = shift;
 298
 299     my $kdbx = $self->kdbx;
 300
 301     my $min_version = $kdbx->minimum_version;
 302     if ($kdbx->version < $min_version && $self->allow_upgrade) {
 303         alert sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version),
 304             version => $kdbx->version, min_version => $min_version;
 305         $kdbx->version($min_version);
 306     }
 307     $self->_rebless;
 308
 309     if (ref($self) =~ /::(?:KDB|V[34])$/) {
 310         $key //= $kdbx->key ? $kdbx->key->reload : undef;
 311         defined $key or throw 'Must provide a master key', type => 'key.missing';
 312     }
 313
 314     $self->_prepare;
 315
 316     my $magic = $self->_write_magic_numbers($fh);
 317     my $headers = $self->_write_headers($fh);
 318
 319     $kdbx->unlock;
 320
 321     $self->_write_body($fh, $key, "$magic$headers");
 322
 323     return $kdbx;
 324 }
 325
 326 sub _prepare {
 327     my $self = shift;
 328     my $kdbx = $self->kdbx;
 329
 330     if ($kdbx->version < KDBX_VERSION_4_0) {
 331         # force Salsa20 inner random stream
 332         $kdbx->inner_random_stream_id(STREAM_ID_SALSA20);
 333         my $key = $kdbx->inner_random_stream_key;
 334         substr($key, 32) = '';
 335         $kdbx->inner_random_stream_key($key);
 336     }
 337
 338     $kdbx->randomize_seeds if $self->randomize_seeds;
 339 }
 340
 341 sub _write_magic_numbers {
 342     my $self = shift;
 343     my $fh = shift;
 344
 345     my $kdbx = $self->kdbx;
 346
 347     $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', sig1 => $kdbx->sig1;
 348     $kdbx->version < KDBX_VERSION_OLDEST || KDBX_VERSION_LATEST < $kdbx->version
 349         and throw 'Unsupported file version', version => $kdbx->version;
 350
 351     my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version);
 352
 353     my $buf = pack('L<3', @magic);
 354     $fh->print($buf) or throw 'Failed to write file signature';
 355
 356     return $buf;
 357 }
 358
 359 sub _write_headers { die "Not implemented" }
 360
 361 sub _write_body { die "Not implemented" }
 362
 363 sub _write_inner_body {
 364     my $self = shift;
 365
 366     my $current_pkg = ref $self;
 367     require Scope::Guard;
 368     my $guard = Scope::Guard->new(sub { bless $self, $current_pkg });
 369
 370     $self->_rebless($self->inner_format);
 371     $self->_write_inner_body(@_);
 372 }
 373
 374 1;