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     # my $fh = eval { File::Temp->new(TEMPLATE => "${filepath}-XXXXXX", CLEANUP => 1) };
 175     # my $filepath_temp = $fh->filename;
 176     # if (!$fh or my $err = $@) {
 177     #     $err //= 'Unknown error';
 178     #     throw sprintf('Open file failed (%s): %s', $filepath_temp, $err),
 179     #         error       => $err,
 180     #         filepath    => $filepath_temp;
 181     # }
 182     open(my $fh, '>:raw', $filepath) or die "open failed ($filepath): $!";
 183     binmode($fh);
 184     # $fh->autoflush(1);
 185
 186     $self = $self->new if !ref $self;
 187     $self->init(%args, fh => $fh, filepath => $filepath);
 188     # binmode($fh);
 189     $self->_dump($fh, $key);
 190
 191     # binmode($fh, ':raw');
 192     # close($fh);
 193
 194     # my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
 195
 196     # my $mode = $args{mode} // $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
 197     # my $uid  = $args{uid}  // $file_uid  // -1;
 198     # my $gid  = $args{gid}  // $file_gid  // -1;
 199     # chmod($mode, $filepath_temp) if defined $mode;
 200     # chown($uid, $gid, $filepath_temp);
 201     # rename($filepath_temp, $filepath) or throw "Failed to write file ($filepath): $!", filepath => $filepath;
 202
 203     return $self;
 204 }
 205
 206 =method dump_handle
 207
 208     $dumper->dump_handle($fh, $key);
 209     $dumper->dump_handle(*IO, $key);
 210
 211 Dump a KDBX file to an input stream / file handle.
 212
 213 =cut
 214
 215 sub dump_handle {
 216     my $self = shift;
 217     my $fh   = shift;
 218     my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
 219
 220     $fh = *STDOUT if $fh eq '-';
 221
 222     my $key = delete $args{key};
 223     $args{kdbx} //= $self->kdbx;
 224
 225     $self = $self->new if !ref $self;
 226     $self->init(%args, fh => $fh)->_dump($fh, $key);
 227 }
 228
 229 =attr kdbx
 230
 231     $kdbx = $dumper->kdbx;
 232     $dumper->kdbx($kdbx);
 233
 234 Get or set the L<File::KDBX> instance with the data to be dumped.
 235
 236 =cut
 237
 238 sub kdbx {
 239     my $self = shift;
 240     return File::KDBX->new if !ref $self;
 241     $self->{kdbx} = shift if @_;
 242     $self->{kdbx} //= File::KDBX->new;
 243 }
 244
 245 =attr format
 246
 247 =cut
 248
 249 sub format { $_[0]->{format} }
 250 sub inner_format { $_[0]->{inner_format} // 'XML' }
 251
 252 =attr min_version
 253
 254     $min_version = File::KDBX::Dumper->min_version;
 255
 256 Get the minimum KDBX file version supported, which is 3.0 or C<0x00030000> as
 257 it is encoded.
 258
 259 To generate older KDBX files unsupported by this module, try L<File::KeePass>.
 260
 261 =cut
 262
 263 sub min_version { KDBX_VERSION_OLDEST }
 264
 265 sub upgrade { $_[0]->{upgrade} // 1 }
 266
 267 sub randomize_seeds { $_[0]->{randomize_seeds} // 1 }
 268
 269 sub _fh { $_[0]->{fh} or throw 'IO handle not set' }
 270
 271 sub _dump {
 272     my $self = shift;
 273     my $fh = shift;
 274     my $key = shift;
 275
 276     my $kdbx = $self->kdbx;
 277
 278     my $min_version = $kdbx->minimum_version;
 279     if ($kdbx->version < $min_version && $self->upgrade) {
 280         alert sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version),
 281             version => $kdbx->version, min_version => $min_version;
 282         $kdbx->version($min_version);
 283     }
 284     $self->_rebless;
 285
 286     if (ref($self) =~ /::(?:KDB|V[34])$/) {
 287         $key //= $kdbx->key ? $kdbx->key->reload : undef;
 288         defined $key or throw 'Must provide a master key', type => 'key.missing';
 289     }
 290
 291     $self->_prepare;
 292
 293     my $magic = $self->_write_magic_numbers($fh);
 294     my $headers = $self->_write_headers($fh);
 295
 296     $kdbx->unlock;
 297
 298     $self->_write_body($fh, $key, "$magic$headers");
 299
 300     return $kdbx;
 301 }
 302
 303 sub _prepare {
 304     my $self = shift;
 305     my $kdbx = $self->kdbx;
 306
 307     if ($kdbx->version < KDBX_VERSION_4_0) {
 308         # force Salsa20 inner random stream
 309         $kdbx->inner_random_stream_id(STREAM_ID_SALSA20);
 310         my $key = $kdbx->inner_random_stream_key;
 311         substr($key, 32) = '';
 312         $kdbx->inner_random_stream_key($key);
 313     }
 314
 315     $kdbx->randomize_seeds if $self->randomize_seeds;
 316 }
 317
 318 sub _write_magic_numbers {
 319     my $self = shift;
 320     my $fh = shift;
 321
 322     my $kdbx = $self->kdbx;
 323
 324     $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', sig1 => $kdbx->sig1;
 325     $kdbx->version < $self->min_version || KDBX_VERSION_LATEST < $kdbx->version
 326         and throw 'Unsupported file version', version => $kdbx->version;
 327
 328     my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version);
 329
 330     my $buf = pack('L<3', @magic);
 331     $fh->print($buf) or throw 'Failed to write file signature';
 332
 333     return $buf;
 334 }
 335
 336 sub _write_headers { die "Not implemented" }
 337
 338 sub _write_body { die "Not implemented" }
 339
 340 sub _write_inner_body {
 341     my $self = shift;
 342
 343     my $current_pkg = ref $self;
 344     require Scope::Guard;
 345     my $guard = Scope::Guard->new(sub { bless $self, $current_pkg });
 346
 347     $self->_rebless($self->inner_format);
 348     $self->_write_inner_body(@_);
 349 }
 350
 351 1;