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 :load assert_64bit 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         assert_64bit;
 133         my $neg = $variant < 0;
 134         my @b = unpack('L>2', pack('Q>', $variant));
 135         return VMAP_TYPE_INT64  if $b[0] && $neg;
 136         return VMAP_TYPE_UINT64 if $b[0];
 137         return VMAP_TYPE_INT32  if $neg;
 138         return VMAP_TYPE_UINT32;
 139     }
 140     elsif (is_utf8($variant)) {
 141         return VMAP_TYPE_STRING;
 142     }
 143     return VMAP_TYPE_BYTEARRAY;
 144 }
 145
 146 sub _write_variant_dictionary {
 147     my $self = shift;
 148     my $dict = shift || {};
 149     my $types = shift || {};
 150
 151     my $buf = '';
 152
 153     $buf .= pack('S<', VMAP_VERSION);
 154
 155     for my $key (sort keys %$dict) {
 156         my $val = $dict->{$key};
 157
 158         my $type = $types->{$key} // $self->_intuit_variant_type($val);
 159         $buf .= pack('C', $type);
 160
 161         if ($type == VMAP_TYPE_UINT32) {
 162             $val = pack('L<', $val);
 163         }
 164         elsif ($type == VMAP_TYPE_UINT64) {
 165             assert_64bit;
 166             $val = pack('Q<', $val);
 167         }
 168         elsif ($type == VMAP_TYPE_BOOL) {
 169             $val = pack('C', $val);
 170         }
 171         elsif ($type == VMAP_TYPE_INT32) {
 172             $val = pack('l', $val);
 173         }
 174         elsif ($type == VMAP_TYPE_INT64) {
 175             assert_64bit;
 176             $val = pack('q<', $val);
 177         }
 178         elsif ($type == VMAP_TYPE_STRING) {
 179             $val = encode('UTF-8', $val);
 180         }
 181         elsif ($type == VMAP_TYPE_BYTEARRAY) {
 182             # $val = substr($$buf, $pos, $vlen);
 183             # $val = [split //, $val];
 184         }
 185         else {
 186             throw 'Unknown variant dictionary value type', type => $type;
 187         }
 188
 189         my ($klen, $vlen) = (length($key), length($val));
 190         $buf .= pack("L< a$klen L< a$vlen", $klen, $key, $vlen, $val);
 191     }
 192
 193     $buf .= pack('C', VMAP_TYPE_END);
 194
 195     return $buf;
 196 }
 197
 198 sub _write_body {
 199     my $self = shift;
 200     my $fh   = shift;
 201     my $key  = shift;
 202     my $header_data = shift;
 203     my $kdbx = $self->kdbx;
 204
 205     # assert all required headers present
 206     for my $field (
 207         HEADER_CIPHER_ID,
 208         HEADER_ENCRYPTION_IV,
 209         HEADER_MASTER_SEED,
 210     ) {
 211         defined $kdbx->headers->{$field} or throw "Missing header: $field";
 212     }
 213
 214     my @cleanup;
 215
 216     # write 32-byte checksum
 217     my $header_hash = digest_data('SHA256', $header_data);
 218     $fh->print($header_hash) or throw 'Failed to write header hash';
 219
 220     $key = $kdbx->composite_key($key);
 221     my $transformed_key = $kdbx->kdf->transform($key);
 222     push @cleanup, erase_scoped $transformed_key;
 223
 224     # write 32-byte HMAC for header
 225     my $hmac_key = digest_data('SHA512', $kdbx->headers->{master_seed}, $transformed_key, "\x01");
 226     push @cleanup, erase_scoped $hmac_key;
 227     my $header_hmac = hmac('SHA256',
 228         digest_data('SHA512', "\xff\xff\xff\xff\xff\xff\xff\xff", $hmac_key),
 229         $header_data,
 230     );
 231     $fh->print($header_hmac) or throw 'Failed to write header HMAC';
 232
 233     $kdbx->key($key);
 234
 235     # HMAC-block the rest of the stream
 236     $fh = File::KDBX::IO::HmacBlock->new($fh, key => $hmac_key);
 237
 238     my $final_key = digest_data('SHA256', $kdbx->headers->{master_seed}, $transformed_key);
 239     push @cleanup, erase_scoped $final_key;
 240
 241     my $cipher = $kdbx->cipher(key => $final_key);
 242     $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
 243
 244     my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
 245     if ($compress == COMPRESSION_GZIP) {
 246         load_optional('IO::Compress::Gzip');
 247         $fh = IO::Compress::Gzip->new($fh,
 248             -Level => IO::Compress::Gzip::Z_BEST_COMPRESSION(),
 249             -TextFlag => 1,
 250         ) or throw "Failed to initialize compression library: $IO::Compress::Gzip::GzipError",
 251             error => $IO::Compress::Gzip::GzipError;
 252     }
 253     elsif ($compress != COMPRESSION_NONE) {
 254         throw "Unsupported compression ($compress)\n", compression_flags => $compress;
 255     }
 256
 257     $self->_write_inner_headers($fh);
 258
 259     local $self->{compress_datetimes} = 1;
 260     $self->_write_inner_body($fh, $header_hash);
 261 }
 262
 263 sub _write_inner_headers {
 264     my $self = shift;
 265     my $fh   = shift;
 266
 267     my $kdbx = $self->kdbx;
 268     my $headers = $kdbx->inner_headers;
 269
 270     for my $type (
 271         INNER_HEADER_INNER_RANDOM_STREAM_ID,
 272         INNER_HEADER_INNER_RANDOM_STREAM_KEY,
 273     ) {
 274         defined $headers->{$type} or throw "Missing inner header: $type";
 275         $self->_write_inner_header($fh, $type => $headers->{$type});
 276     }
 277
 278     $self->_write_binaries($fh);
 279
 280     $self->_write_inner_header($fh, INNER_HEADER_END);
 281 }
 282
 283 sub _write_inner_header {
 284     my $self = shift;
 285     my $fh   = shift;
 286     my $type = shift;
 287     my $val  = shift // '';
 288
 289     my $buf = pack('C', $type);
 290     $fh->print($buf) or throw 'Failed to write inner header type';
 291
 292     $type = to_inner_header_constant($type);
 293     if ($type == INNER_HEADER_END) {
 294         # nothing
 295     }
 296     elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID) {
 297         $val = pack('L<', $val);
 298     }
 299     elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY) {
 300         # nothing
 301     }
 302     elsif ($type == INNER_HEADER_BINARY) {
 303         # nothing
 304     }
 305
 306     $buf = pack('L<', length($val));
 307     $fh->print($buf) or throw 'Failed to write inner header value size';
 308     $fh->print($val) or throw 'Failed to write inner header value';
 309 }
 310
 311 sub _write_binaries {
 312     my $self = shift;
 313     my $fh = shift;
 314
 315     my $kdbx = $self->kdbx;
 316
 317     my $new_ref = 0;
 318     my $written = $self->_binaries_written;
 319
 320     my $entries = $kdbx->all_entries(history => true);
 321     for my $entry (@$entries) {
 322         for my $key (keys %{$entry->binaries}) {
 323             my $binary = $entry->binaries->{$key};
 324             if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
 325                 $binary = $kdbx->binaries->{$binary->{ref}};
 326             }
 327
 328             if (!defined $binary->{value}) {
 329                 alert "Skipping binary which has no value: $key", key => $key;
 330                 next;
 331             }
 332
 333             my $hash = digest_data('SHA256', $binary->{value});
 334             if (defined $written->{$hash}) {
 335                 # nothing
 336             }
 337             else {
 338                 my $flags = 0;
 339                 $flags &= INNER_HEADER_BINARY_FLAG_PROTECT if $binary->{protect};
 340
 341                 $self->_write_binary($fh, \$binary->{value}, $flags);
 342                 $written->{$hash} = $new_ref++;
 343             }
 344         }
 345     }
 346 }
 347
 348 sub _write_binary {
 349     my $self = shift;
 350     my $fh = shift;
 351     my $data = shift;
 352     my $flags = shift || 0;
 353
 354     my $buf = pack('C', 0 + INNER_HEADER_BINARY);
 355     $fh->print($buf) or throw 'Failed to write inner header type';
 356
 357     $buf = pack('L<', 1 + length($$data));
 358     $fh->print($buf) or throw 'Failed to write inner header value size';
 359
 360     $buf = pack('C', $flags);
 361     $fh->print($buf) or throw 'Failed to write inner header binary flags';
 362
 363     $fh->print($$data) or throw 'Failed to write inner header value';
 364 }
 365
 366 1;