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

   1 package File::KDBX::Dumper::V4;
   2 # ABSTRACT: Dump KDBX4 files
   3
   4 use warnings;
   5 use strict;
   6
   7 use Crypt::Digest qw(digest_data);
   8 use Crypt::Mac::HMAC qw(hmac);
   9 use Encode qw(encode is_utf8);
  10 use File::KDBX::Constants qw(:header :inner_header :compression :kdf :variant_map);
  11 use File::KDBX::Error;
  12 use File::KDBX::IO::Crypt;
  13 use File::KDBX::IO::HmacBlock;
  14 use File::KDBX::Util qw(:class :empty :int :load erase_scoped);
  15 use IO::Handle;
  16 use Scalar::Util qw(looks_like_number);
  17 use boolean qw(:all);
  18 use namespace::clean;
  19
  20 extends 'File::KDBX::Dumper';
  21
  22 our $VERSION = '999.999'; # VERSION
  23
  24 has _binaries_written => {}, is => 'ro';
  25
  26 sub _write_headers {
  27     my $self = shift;
  28     my $fh = shift;
  29
  30     my $kdbx = $self->kdbx;
  31     my $headers = $kdbx->headers;
  32     my $buf = '';
  33
  34     # Always write the standard AES KDF UUID, for compatibility
  35     local $headers->{+HEADER_KDF_PARAMETERS}->{+KDF_PARAM_UUID} = KDF_UUID_AES
  36         if $headers->{+HEADER_KDF_PARAMETERS}->{+KDF_PARAM_UUID} eq KDF_UUID_AES_CHALLENGE_RESPONSE;
  37
  38     if (nonempty (my $comment = $headers->{+HEADER_COMMENT})) {
  39         $buf .= $self->_write_header($fh, HEADER_COMMENT, $comment);
  40     }
  41     for my $type (
  42         HEADER_CIPHER_ID,
  43         HEADER_COMPRESSION_FLAGS,
  44         HEADER_MASTER_SEED,
  45         HEADER_ENCRYPTION_IV,
  46         HEADER_KDF_PARAMETERS,
  47     ) {
  48         defined $headers->{$type} or throw "Missing value for required header: $type", type => $type;
  49         $buf .= $self->_write_header($fh, $type, $headers->{$type});
  50     }
  51     $buf .= $self->_write_header($fh, HEADER_PUBLIC_CUSTOM_DATA, $headers->{+HEADER_PUBLIC_CUSTOM_DATA})
  52         if defined $headers->{+HEADER_PUBLIC_CUSTOM_DATA} && keys %{$headers->{+HEADER_PUBLIC_CUSTOM_DATA}};
  53     $buf .= $self->_write_header($fh, HEADER_END);
  54
  55     return $buf;
  56 }
  57
  58 sub _write_header {
  59     my $self = shift;
  60     my $fh   = shift;
  61     my $type = shift;
  62     my $val  = shift // '';
  63
  64     $type = to_header_constant($type);
  65     if ($type == HEADER_END) {
  66         # nothing
  67     }
  68     elsif ($type == HEADER_COMMENT) {
  69         $val = encode('UTF-8', $val);
  70     }
  71     elsif ($type == HEADER_CIPHER_ID) {
  72         my $size = length($val);
  73         $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size;
  74     }
  75     elsif ($type == HEADER_COMPRESSION_FLAGS) {
  76         $val = pack('L<', $val);
  77     }
  78     elsif ($type == HEADER_MASTER_SEED) {
  79         my $size = length($val);
  80         $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size;
  81     }
  82     elsif ($type == HEADER_ENCRYPTION_IV) {
  83         # nothing
  84     }
  85     elsif ($type == HEADER_KDF_PARAMETERS) {
  86         $val = $self->_write_variant_dictionary($val, {
  87             KDF_PARAM_UUID()               => VMAP_TYPE_BYTEARRAY,
  88             KDF_PARAM_AES_ROUNDS()         => VMAP_TYPE_UINT64,
  89             KDF_PARAM_AES_SEED()           => VMAP_TYPE_BYTEARRAY,
  90             KDF_PARAM_ARGON2_SALT()        => VMAP_TYPE_BYTEARRAY,
  91             KDF_PARAM_ARGON2_PARALLELISM() => VMAP_TYPE_UINT32,
  92             KDF_PARAM_ARGON2_MEMORY()      => VMAP_TYPE_UINT64,
  93             KDF_PARAM_ARGON2_ITERATIONS()  => VMAP_TYPE_UINT64,
  94             KDF_PARAM_ARGON2_VERSION()     => VMAP_TYPE_UINT32,
  95             KDF_PARAM_ARGON2_SECRET()      => VMAP_TYPE_BYTEARRAY,
  96             KDF_PARAM_ARGON2_ASSOCDATA()   => VMAP_TYPE_BYTEARRAY,
  97         });
  98     }
  99     elsif ($type == HEADER_PUBLIC_CUSTOM_DATA) {
 100         $val = $self->_write_variant_dictionary($val);
 101     }
 102     elsif ($type == HEADER_INNER_RANDOM_STREAM_ID ||
 103            $type == HEADER_INNER_RANDOM_STREAM_KEY ||
 104            $type == HEADER_TRANSFORM_SEED ||
 105            $type == HEADER_TRANSFORM_ROUNDS ||
 106            $type == HEADER_STREAM_START_BYTES) {
 107         throw "Unexpected KDBX3 header: $type", type => $type;
 108     }
 109     elsif ($type == HEADER_COMMENT) {
 110         throw "Unexpected KDB header: $type", type => $type;
 111     }
 112     else {
 113         alert "Unknown header: $type", type => $type;
 114     }
 115
 116     my $size = length($val);
 117     my $buf = pack('C L<', 0+$type, $size);
 118
 119     $fh->print($buf, $val) or throw 'Failed to write header';
 120
 121     return "$buf$val";
 122 }
 123
 124 sub _intuit_variant_type {
 125     my $self = shift;
 126     my $variant = shift;
 127
 128     if (isBoolean($variant)) {
 129         return VMAP_TYPE_BOOL;
 130     }
 131     elsif (looks_like_number($variant) && ($variant + 0) =~ /^\d+$/) {
 132         my $neg = $variant < 0;
 133         my @b = unpack('L>2', scalar reverse pack_Ql($variant));
 134         return VMAP_TYPE_INT64  if $b[0] && $neg;
 135         return VMAP_TYPE_UINT64 if $b[0];
 136         return VMAP_TYPE_INT32  if $neg;
 137         return VMAP_TYPE_UINT32;
 138     }
 139     elsif (is_utf8($variant)) {
 140         return VMAP_TYPE_STRING;
 141     }
 142     return VMAP_TYPE_BYTEARRAY;
 143 }
 144
 145 sub _write_variant_dictionary {
 146     my $self = shift;
 147     my $dict = shift || {};
 148     my $types = shift || {};
 149
 150     my $buf = '';
 151
 152     $buf .= pack('S<', VMAP_VERSION);
 153
 154     for my $key (sort keys %$dict) {
 155         my $val = $dict->{$key};
 156
 157         my $type = $types->{$key} // $self->_intuit_variant_type($val);
 158         $buf .= pack('C', $type);
 159
 160         if ($type == VMAP_TYPE_UINT32) {
 161             $val = pack('L<', $val);
 162         }
 163         elsif ($type == VMAP_TYPE_UINT64) {
 164             $val = pack_Ql($val);
 165         }
 166         elsif ($type == VMAP_TYPE_BOOL) {
 167             $val = pack('C', $val);
 168         }
 169         elsif ($type == VMAP_TYPE_INT32) {
 170             $val = pack('l', $val);
 171         }
 172         elsif ($type == VMAP_TYPE_INT64) {
 173             $val = pack_ql($val);
 174         }
 175         elsif ($type == VMAP_TYPE_STRING) {
 176             $val = encode('UTF-8', $val);
 177         }
 178         elsif ($type == VMAP_TYPE_BYTEARRAY) {
 179             # $val = substr($$buf, $pos, $vlen);
 180             # $val = [split //, $val];
 181         }
 182         else {
 183             throw 'Unknown variant dictionary value type', type => $type;
 184         }
 185
 186         my ($klen, $vlen) = (length($key), length($val));
 187         $buf .= pack("L< a$klen L< a$vlen", $klen, $key, $vlen, $val);
 188     }
 189
 190     $buf .= pack('C', VMAP_TYPE_END);
 191
 192     return $buf;
 193 }
 194
 195 sub _write_body {
 196     my $self = shift;
 197     my $fh   = shift;
 198     my $key  = shift;
 199     my $header_data = shift;
 200     my $kdbx = $self->kdbx;
 201
 202     # assert all required headers present
 203     for my $field (
 204         HEADER_CIPHER_ID,
 205         HEADER_ENCRYPTION_IV,
 206         HEADER_MASTER_SEED,
 207     ) {
 208         defined $kdbx->headers->{$field} or throw "Missing header: $field";
 209     }
 210
 211     my @cleanup;
 212
 213     # write 32-byte checksum
 214     my $header_hash = digest_data('SHA256', $header_data);
 215     $fh->print($header_hash) or throw 'Failed to write header hash';
 216
 217     $key = $kdbx->composite_key($key);
 218     my $transformed_key = $kdbx->kdf->transform($key);
 219     push @cleanup, erase_scoped $transformed_key;
 220
 221     # write 32-byte HMAC for header
 222     my $hmac_key = digest_data('SHA512', $kdbx->headers->{master_seed}, $transformed_key, "\x01");
 223     push @cleanup, erase_scoped $hmac_key;
 224     my $header_hmac = hmac('SHA256',
 225         digest_data('SHA512', "\xff\xff\xff\xff\xff\xff\xff\xff", $hmac_key),
 226         $header_data,
 227     );
 228     $fh->print($header_hmac) or throw 'Failed to write header HMAC';
 229
 230     $kdbx->key($key);
 231
 232     # HMAC-block the rest of the stream
 233     $fh = File::KDBX::IO::HmacBlock->new($fh, key => $hmac_key);
 234
 235     my $final_key = digest_data('SHA256', $kdbx->headers->{master_seed}, $transformed_key);
 236     push @cleanup, erase_scoped $final_key;
 237
 238     my $cipher = $kdbx->cipher(key => $final_key);
 239     $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
 240
 241     my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
 242     if ($compress == COMPRESSION_GZIP) {
 243         load_optional('IO::Compress::Gzip');
 244         $fh = IO::Compress::Gzip->new($fh,
 245             -Level => IO::Compress::Gzip::Z_BEST_COMPRESSION(),
 246             -TextFlag => 1,
 247         ) or throw "Failed to initialize compression library: $IO::Compress::Gzip::GzipError",
 248             error => $IO::Compress::Gzip::GzipError;
 249     }
 250     elsif ($compress != COMPRESSION_NONE) {
 251         throw "Unsupported compression ($compress)\n", compression_flags => $compress;
 252     }
 253
 254     $self->_write_inner_headers($fh);
 255
 256     local $self->{compress_datetimes} = 1;
 257     $self->_write_inner_body($fh, $header_hash);
 258 }
 259
 260 sub _write_inner_headers {
 261     my $self = shift;
 262     my $fh   = shift;
 263
 264     my $kdbx = $self->kdbx;
 265     my $headers = $kdbx->inner_headers;
 266
 267     for my $type (
 268         INNER_HEADER_INNER_RANDOM_STREAM_ID,
 269         INNER_HEADER_INNER_RANDOM_STREAM_KEY,
 270     ) {
 271         defined $headers->{$type} or throw "Missing inner header: $type";
 272         $self->_write_inner_header($fh, $type => $headers->{$type});
 273     }
 274
 275     $self->_write_binaries($fh);
 276
 277     $self->_write_inner_header($fh, INNER_HEADER_END);
 278 }
 279
 280 sub _write_inner_header {
 281     my $self = shift;
 282     my $fh   = shift;
 283     my $type = shift;
 284     my $val  = shift // '';
 285
 286     my $buf = pack('C', $type);
 287     $fh->print($buf) or throw 'Failed to write inner header type';
 288
 289     $type = to_inner_header_constant($type);
 290     if ($type == INNER_HEADER_END) {
 291         # nothing
 292     }
 293     elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID) {
 294         $val = pack('L<', $val);
 295     }
 296     elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY) {
 297         # nothing
 298     }
 299     elsif ($type == INNER_HEADER_BINARY) {
 300         # nothing
 301     }
 302
 303     $buf = pack('L<', length($val));
 304     $fh->print($buf) or throw 'Failed to write inner header value size';
 305     $fh->print($val) or throw 'Failed to write inner header value';
 306 }
 307
 308 sub _write_binaries {
 309     my $self = shift;
 310     my $fh = shift;
 311
 312     my $kdbx = $self->kdbx;
 313
 314     my $new_ref = 0;
 315     my $written = $self->_binaries_written;
 316
 317     my $entries = $kdbx->entries(history => 1);
 318     while (my $entry = $entries->next) {
 319         for my $key (keys %{$entry->binaries}) {
 320             my $binary = $entry->binaries->{$key};
 321             if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
 322                 $binary = $kdbx->binaries->{$binary->{ref}};
 323             }
 324
 325             if (!defined $binary->{value}) {
 326                 alert "Skipping binary which has no value: $key", key => $key;
 327                 next;
 328             }
 329
 330             my $hash = digest_data('SHA256', $binary->{value});
 331             if (defined $written->{$hash}) {
 332                 # nothing
 333             }
 334             else {
 335                 my $flags = 0;
 336                 $flags &= INNER_HEADER_BINARY_FLAG_PROTECT if $binary->{protect};
 337
 338                 $self->_write_binary($fh, \$binary->{value}, $flags);
 339                 $written->{$hash} = $new_ref++;
 340             }
 341         }
 342     }
 343 }
 344
 345 sub _write_binary {
 346     my $self = shift;
 347     my $fh = shift;
 348     my $data = shift;
 349     my $flags = shift || 0;
 350
 351     my $buf = pack('C', 0 + INNER_HEADER_BINARY);
 352     $fh->print($buf) or throw 'Failed to write inner header type';
 353
 354     $buf = pack('L<', 1 + length($$data));
 355     $fh->print($buf) or throw 'Failed to write inner header value size';
 356
 357     $buf = pack('C', $flags);
 358     $fh->print($buf) or throw 'Failed to write inner header binary flags';
 359
 360     $fh->print($$data) or throw 'Failed to write inner header value';
 361 }
 362
 363 1;