1 package File
::KDBX
::Dumper
::V4
;
2 # ABSTRACT: Dump KDBX4 files
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);
16 use Scalar
::Util
qw(looks_like_number);
20 extends
'File::KDBX::Dumper';
22 our $VERSION = '0.905'; # VERSION
24 has _binaries_written
=> {}, is => 'ro';
30 my $kdbx = $self->kdbx;
31 my $headers = $kdbx->headers;
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
;
38 if (nonempty
(my $comment = $headers->{+HEADER_COMMENT
})) {
39 $buf .= $self->_write_header($fh, HEADER_COMMENT
, $comment);
43 HEADER_COMPRESSION_FLAGS
,
46 HEADER_KDF_PARAMETERS
,
48 defined $headers->{$type} or throw
"Missing value for required header: $type", type
=> $type;
49 $buf .= $self->_write_header($fh, $type, $headers->{$type});
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
);
62 my $val = shift // '';
64 $type = to_header_constant
($type);
65 if ($type == HEADER_END
) {
68 elsif ($type == HEADER_COMMENT
) {
69 $val = encode
('UTF-8', $val);
71 elsif ($type == HEADER_CIPHER_ID
) {
72 my $size = length($val);
73 $size == 16 or throw
'Invalid cipher UUID length', got
=> $size, expected
=> $size;
75 elsif ($type == HEADER_COMPRESSION_FLAGS
) {
76 $val = pack('L<', $val);
78 elsif ($type == HEADER_MASTER_SEED
) {
79 my $size = length($val);
80 $size == 32 or throw
'Invalid master seed length', got
=> $size, expected
=> $size;
82 elsif ($type == HEADER_ENCRYPTION_IV
) {
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
,
99 elsif ($type == HEADER_PUBLIC_CUSTOM_DATA
) {
100 $val = $self->_write_variant_dictionary($val);
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;
109 elsif ($type == HEADER_COMMENT
) {
110 throw
"Unexpected KDB header: $type", type
=> $type;
113 alert
"Unknown header: $type", type
=> $type;
116 my $size = length($val);
117 my $buf = pack('C L<', 0+$type, $size);
119 $fh->print($buf, $val) or throw
'Failed to write header';
124 sub _intuit_variant_type
{
128 if (isBoolean
($variant)) {
129 return VMAP_TYPE_BOOL
;
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
;
139 elsif (is_utf8
($variant)) {
140 return VMAP_TYPE_STRING
;
142 return VMAP_TYPE_BYTEARRAY
;
145 sub _write_variant_dictionary
{
147 my $dict = shift || {};
148 my $types = shift || {};
152 $buf .= pack('S<', VMAP_VERSION
);
154 for my $key (sort keys %$dict) {
155 my $val = $dict->{$key};
157 my $type = $types->{$key} // $self->_intuit_variant_type($val);
158 $buf .= pack('C', $type);
160 if ($type == VMAP_TYPE_UINT32
) {
161 $val = pack('L<', $val);
163 elsif ($type == VMAP_TYPE_UINT64
) {
164 $val = pack_Ql
($val);
166 elsif ($type == VMAP_TYPE_BOOL
) {
167 $val = pack('C', $val);
169 elsif ($type == VMAP_TYPE_INT32
) {
170 $val = pack('l', $val);
172 elsif ($type == VMAP_TYPE_INT64
) {
173 $val = pack_ql
($val);
175 elsif ($type == VMAP_TYPE_STRING
) {
176 $val = encode
('UTF-8', $val);
178 elsif ($type == VMAP_TYPE_BYTEARRAY
) {
179 # $val = substr($$buf, $pos, $vlen);
180 # $val = [split //, $val];
183 throw
'Unknown variant dictionary value type', type
=> $type;
186 my ($klen, $vlen) = (length($key), length($val));
187 $buf .= pack("L< a$klen L< a$vlen", $klen, $key, $vlen, $val);
190 $buf .= pack('C', VMAP_TYPE_END
);
199 my $header_data = shift;
200 my $kdbx = $self->kdbx;
202 # assert all required headers present
205 HEADER_ENCRYPTION_IV
,
208 defined $kdbx->headers->{$field} or throw
"Missing header: $field";
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';
217 $key = $kdbx->composite_key($key);
218 my $transformed_key = $kdbx->kdf->transform($key);
219 push @cleanup, erase_scoped
$transformed_key;
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),
228 $fh->print($header_hmac) or throw
'Failed to write header HMAC';
232 # HMAC-block the rest of the stream
233 $fh = File
::KDBX
::IO
::HmacBlock-
>new($fh, key
=> $hmac_key);
235 my $final_key = digest_data
('SHA256', $kdbx->headers->{master_seed
}, $transformed_key);
236 push @cleanup, erase_scoped
$final_key;
238 my $cipher = $kdbx->cipher(key
=> $final_key);
239 $fh = File
::KDBX
::IO
::Crypt-
>new($fh, cipher
=> $cipher);
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
(),
247 ) or throw
"Failed to initialize compression library: $IO::Compress::Gzip::GzipError",
248 error
=> $IO::Compress
::Gzip
::GzipError
;
250 elsif ($compress != COMPRESSION_NONE
) {
251 throw
"Unsupported compression ($compress)\n", compression_flags
=> $compress;
254 $self->_write_inner_headers($fh);
256 local $self->{compress_datetimes
} = 1;
257 $self->_write_inner_body($fh, $header_hash);
260 sub _write_inner_headers
{
264 my $kdbx = $self->kdbx;
265 my $headers = $kdbx->inner_headers;
268 INNER_HEADER_INNER_RANDOM_STREAM_ID
,
269 INNER_HEADER_INNER_RANDOM_STREAM_KEY
,
271 defined $headers->{$type} or throw
"Missing inner header: $type";
272 $self->_write_inner_header($fh, $type => $headers->{$type});
275 $self->_write_binaries($fh);
277 $self->_write_inner_header($fh, INNER_HEADER_END
);
280 sub _write_inner_header
{
284 my $val = shift // '';
286 my $buf = pack('C', $type);
287 $fh->print($buf) or throw
'Failed to write inner header type';
289 $type = to_inner_header_constant
($type);
290 if ($type == INNER_HEADER_END
) {
293 elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID
) {
294 $val = pack('L<', $val);
296 elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY
) {
299 elsif ($type == INNER_HEADER_BINARY
) {
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';
308 sub _write_binaries
{
312 my $kdbx = $self->kdbx;
315 my $written = $self->_binaries_written;
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}};
325 if (!defined $binary->{value
}) {
326 alert
"Skipping binary which has no value: $key", key
=> $key;
330 my $hash = digest_data
('SHA256', $binary->{value
});
331 if (defined $written->{$hash}) {
336 $flags &= INNER_HEADER_BINARY_FLAG_PROTECT
if $binary->{protect
};
338 $self->_write_binary($fh, \
$binary->{value
}, $flags);
339 $written->{$hash} = $new_ref++;
349 my $flags = shift || 0;
351 my $buf = pack('C', 0 + INNER_HEADER_BINARY
);
352 $fh->print($buf) or throw
'Failed to write inner header type';
354 $buf = pack('L<', 1 + length($$data));
355 $fh->print($buf) or throw
'Failed to write inner header value size';
357 $buf = pack('C', $flags);
358 $fh->print($buf) or throw
'Failed to write inner header binary flags';
360 $fh->print($$data) or throw
'Failed to write inner header value';
373 File::KDBX::Dumper::V4 - Dump KDBX4 files
381 Please report any bugs or feature requests on the bugtracker website
382 L<https://github.com/chazmcgarvey/File-KDBX/issues>
384 When submitting a bug or request, please include a test-file or a
385 patch to an existing test-file that illustrates the bug or desired
390 Charles McGarvey <ccm@cpan.org>
392 =head1 COPYRIGHT AND LICENSE
394 This software is copyright (c) 2022 by Charles McGarvey.
396 This is free software; you can redistribute it and/or modify it under
397 the same terms as the Perl 5 programming language system itself.