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
::Util
qw(:empty assert_64bit erase_scoped);
14 use PerlIO
::via
::File
::KDBX
::Crypt
;
15 use PerlIO
::via
::File
::KDBX
::HmacBlock
;
16 use Scalar
::Util
qw(looks_like_number);
20 use parent
'File::KDBX::Dumper';
22 our $VERSION = '999.999'; # VERSION
24 sub _binaries_written
{ $_[0]->{_binaries_written
} //= {} }
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 = KDBX_HEADER
($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+$/) {
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
;
140 elsif (is_utf8
($variant)) {
141 return VMAP_TYPE_STRING
;
143 return VMAP_TYPE_BYTEARRAY
;
146 sub _write_variant_dictionary
{
148 my $dict = shift || {};
149 my $types = shift || {};
153 $buf .= pack('S<', VMAP_VERSION
);
155 for my $key (sort keys %$dict) {
156 my $val = $dict->{$key};
158 my $type = $types->{$key} // $self->_intuit_variant_type($val);
159 $buf .= pack('C', $type);
161 if ($type == VMAP_TYPE_UINT32
) {
162 $val = pack('L<', $val);
164 elsif ($type == VMAP_TYPE_UINT64
) {
166 $val = pack('Q<', $val);
168 elsif ($type == VMAP_TYPE_BOOL
) {
169 $val = pack('C', $val);
171 elsif ($type == VMAP_TYPE_INT32
) {
172 $val = pack('l', $val);
174 elsif ($type == VMAP_TYPE_INT64
) {
176 $val = pack('q<', $val);
178 elsif ($type == VMAP_TYPE_STRING
) {
179 $val = encode
('UTF-8', $val);
181 elsif ($type == VMAP_TYPE_BYTEARRAY
) {
182 # $val = substr($$buf, $pos, $vlen);
183 # $val = [split //, $val];
186 throw
'Unknown variant dictionary value type', type
=> $type;
189 my ($klen, $vlen) = (length($key), length($val));
190 $buf .= pack("L< a$klen L< a$vlen", $klen, $key, $vlen, $val);
193 $buf .= pack('C', VMAP_TYPE_END
);
202 my $header_data = shift;
203 my $kdbx = $self->kdbx;
205 # assert all required headers present
208 HEADER_ENCRYPTION_IV
,
211 defined $kdbx->headers->{$field} or throw
"Missing header: $field";
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';
220 $key = $kdbx->composite_key($key);
221 my $transformed_key = $kdbx->kdf->transform($key);
222 push @cleanup, erase_scoped
$transformed_key;
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),
231 $fh->print($header_hmac) or throw
'Failed to write header HMAC';
235 # HMAC-block the rest of the stream
236 PerlIO
::via
::File
::KDBX
::HmacBlock-
>push($fh, $hmac_key);
238 my $final_key = digest_data
('SHA256', $kdbx->headers->{master_seed
}, $transformed_key);
239 push @cleanup, erase_scoped
$final_key;
241 my $cipher = $kdbx->cipher(key
=> $final_key);
242 PerlIO
::via
::File
::KDBX
::Crypt-
>push($fh, $cipher);
244 my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS
};
245 if ($compress == COMPRESSION_GZIP
) {
246 require PerlIO
::via
::File
::KDBX
::Compression
;
247 PerlIO
::via
::File
::KDBX
::Compression-
>push($fh);
249 elsif ($compress != COMPRESSION_NONE
) {
250 throw
"Unsupported compression ($compress)\n", compression_flags
=> $compress;
253 $self->_write_inner_headers($fh);
255 local $self->{compress_datetimes
} = 1;
256 $self->_write_inner_body($fh, $header_hash);
258 binmode($fh, ':pop') if $compress;
259 binmode($fh, ':pop:pop');
262 sub _write_inner_headers
{
266 my $kdbx = $self->kdbx;
267 my $headers = $kdbx->inner_headers;
270 INNER_HEADER_INNER_RANDOM_STREAM_ID
,
271 INNER_HEADER_INNER_RANDOM_STREAM_KEY
,
273 defined $headers->{$type} or throw
"Missing inner header: $type";
274 $self->_write_inner_header($fh, $type => $headers->{$type});
277 $self->_write_binaries($fh);
279 $self->_write_inner_header($fh, INNER_HEADER_END
);
282 sub _write_inner_header
{
286 my $val = shift // '';
288 my $buf = pack('C', $type);
289 $fh->print($buf) or throw
'Failed to write inner header type';
291 $type = KDBX_INNER_HEADER
($type);
293 if ($type == INNER_HEADER_END
) {
296 elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID
) {
297 $val = pack('L<', $val);
299 elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY
) {
302 elsif ($type == INNER_HEADER_BINARY
) {
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';
311 sub _write_binaries
{
315 my $kdbx = $self->kdbx;
318 my $written = $self->_binaries_written;
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}};
328 if (!defined $binary->{value
}) {
329 alert
"Skipping binary which has no value: $key", key
=> $key;
333 my $hash = digest_data
('SHA256', $binary->{value
});
334 if (defined $written->{$hash}) {
339 $flags &= INNER_HEADER_BINARY_FLAG_PROTECT
if $binary->{protect
};
341 $self->_write_binary($fh, \
$binary->{value
}, $flags);
342 $written->{$hash} = $new_ref++;
352 my $flags = shift || 0;
354 my $buf = pack('C', 0 + INNER_HEADER_BINARY
);
355 $fh->print($buf) or throw
'Failed to write inner header type';
357 $buf = pack('L<', 1 + length($$data));
358 $fh->print($buf) or throw
'Failed to write inner header value size';
360 $buf = pack('C', $flags);
361 $fh->print($buf) or throw
'Failed to write inner header binary flags';
363 $fh->print($$data) or throw
'Failed to write inner header value';