File Coverage

blib/lib/File/KDBX/Dumper/V3.pm
Criterion Covered Total %
statement 91 97 93.8
branch 29 46 63.0
condition 2 5 40.0
subroutine 14 14 100.0
pod n/a
total 136 162 83.9


line stmt bran cond sub pod time code
1             package File::KDBX::Dumper::V3;
2             # ABSTRACT: Dump KDBX3 files
3              
4 5     5   2344 use warnings;
  5         10  
  5         149  
5 5     5   26 use strict;
  5         8  
  5         104  
6              
7 5     5   22 use Crypt::Digest qw(digest_data);
  5         8  
  5         200  
8 5     5   36 use Encode qw(encode);
  5         7  
  5         197  
9 5     5   26 use File::KDBX::Constants qw(:header :compression);
  5         8  
  5         788  
10 5     5   31 use File::KDBX::Error;
  5         10  
  5         218  
11 5     5   774 use File::KDBX::IO::Crypt;
  5         17  
  5         208  
12 5     5   1168 use File::KDBX::IO::HashBlock;
  5         12  
  5         190  
13 5     5   25 use File::KDBX::Util qw(:class :empty :int :load erase_scoped);
  5         8  
  5         725  
14 5     5   29 use IO::Handle;
  5         9  
  5         146  
15 5     5   26 use namespace::clean;
  5         9  
  5         21  
16              
17             extends 'File::KDBX::Dumper';
18              
19             our $VERSION = '0.905'; # VERSION
20              
21             sub _write_headers {
22 8     8   16 my $self = shift;
23 8         13 my $fh = shift;
24              
25 8         19 my $kdbx = $self->kdbx;
26 8         25 my $headers = $kdbx->headers;
27 8         13 my $buf = '';
28              
29             # FIXME kinda janky - maybe add a "prepare" hook to massage the KDBX into the correct shape before we get
30             # this far
31 8         23 local $headers->{+HEADER_TRANSFORM_SEED} = $kdbx->transform_seed;
32 8         25 local $headers->{+HEADER_TRANSFORM_ROUNDS} = $kdbx->transform_rounds;
33              
34 8 50       34 if (nonempty (my $comment = $headers->{+HEADER_COMMENT})) {
35 0         0 $buf .= $self->_write_header($fh, HEADER_COMMENT, $comment);
36             }
37 8         26 for my $type (
38             HEADER_CIPHER_ID,
39             HEADER_COMPRESSION_FLAGS,
40             HEADER_MASTER_SEED,
41             HEADER_TRANSFORM_SEED,
42             HEADER_TRANSFORM_ROUNDS,
43             HEADER_ENCRYPTION_IV,
44             HEADER_INNER_RANDOM_STREAM_KEY,
45             HEADER_STREAM_START_BYTES,
46             HEADER_INNER_RANDOM_STREAM_ID,
47             ) {
48 72 50       150 defined $headers->{$type} or throw "Missing value for required header: $type", type => $type;
49 72         136 $buf .= $self->_write_header($fh, $type, $headers->{$type});
50             }
51 8         25 $buf .= $self->_write_header($fh, HEADER_END);
52              
53 8         57 return $buf;
54             }
55              
56             sub _write_header {
57 80     80   90 my $self = shift;
58 80         84 my $fh = shift;
59 80         84 my $type = shift;
60 80   100     163 my $val = shift // '';
61              
62 80         146 $type = to_header_constant($type);
63 80 100 0     323 if ($type == HEADER_END) {
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    0          
    0          
64 8         14 $val = "\r\n\r\n";
65             }
66             elsif ($type == HEADER_COMMENT) {
67 0         0 $val = encode('UTF-8', $val);
68             }
69             elsif ($type == HEADER_CIPHER_ID) {
70 8         23 my $size = length($val);
71 8 50       19 $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size;
72             }
73             elsif ($type == HEADER_COMPRESSION_FLAGS) {
74 8         20 $val = pack('L<', $val);
75             }
76             elsif ($type == HEADER_MASTER_SEED) {
77 8         15 my $size = length($val);
78 8 50       21 $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size;
79             }
80             elsif ($type == HEADER_TRANSFORM_SEED) {
81             # nothing
82             }
83             elsif ($type == HEADER_TRANSFORM_ROUNDS) {
84 8         46 $val = pack_Ql($val);
85             }
86             elsif ($type == HEADER_ENCRYPTION_IV) {
87             # nothing
88             }
89             elsif ($type == HEADER_INNER_RANDOM_STREAM_KEY) {
90             # nothing
91             }
92             elsif ($type == HEADER_STREAM_START_BYTES) {
93             # nothing
94             }
95             elsif ($type == HEADER_INNER_RANDOM_STREAM_ID) {
96 8         23 $val = pack('L<', $val);
97             }
98             elsif ($type == HEADER_KDF_PARAMETERS ||
99             $type == HEADER_PUBLIC_CUSTOM_DATA) {
100 0         0 throw "Unexpected KDBX4 header: $type", type => $type;
101             }
102             elsif ($type == HEADER_COMMENT) {
103 0         0 throw "Unexpected KDB header: $type", type => $type;
104             }
105             else {
106 0         0 alert "Unknown header: $type", type => $type;
107             }
108              
109 80         101 my $size = length($val);
110 80         150 my $buf = pack('C S<', 0+$type, $size);
111              
112 80 50       152 $fh->print($buf, $val) or throw 'Failed to write header';
113              
114 80         832 return "$buf$val";
115             }
116              
117             sub _write_body {
118 8     8   15 my $self = shift;
119 8         12 my $fh = shift;
120 8         20 my $key = shift;
121 8         12 my $header_data = shift;
122 8         21 my $kdbx = $self->kdbx;
123              
124             # assert all required headers present
125 8         23 for my $field (
126             HEADER_CIPHER_ID,
127             HEADER_ENCRYPTION_IV,
128             HEADER_MASTER_SEED,
129             HEADER_INNER_RANDOM_STREAM_KEY,
130             HEADER_STREAM_START_BYTES,
131             ) {
132 40 50       70 defined $kdbx->headers->{$field} or throw "Missing $field";
133             }
134              
135 8         21 my $master_seed = $kdbx->headers->{+HEADER_MASTER_SEED};
136              
137 8         16 my @cleanup;
138 8         25 $key = $kdbx->composite_key($key);
139              
140 8         26 my $response = $key->challenge($master_seed);
141 8         30 push @cleanup, erase_scoped $response;
142              
143 8         113 my $transformed_key = $kdbx->kdf->transform($key);
144 8         39 push @cleanup, erase_scoped $transformed_key;
145              
146 8         125 my $final_key = digest_data('SHA256', $master_seed, $response, $transformed_key);
147 8         33 push @cleanup, erase_scoped $final_key;
148              
149 8         107 my $cipher = $kdbx->cipher(key => $final_key);
150 8         67 $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
151              
152 8 50       29 $fh->print($kdbx->headers->{+HEADER_STREAM_START_BYTES})
153             or throw 'Failed to write start bytes';
154              
155 8         40 $kdbx->key($key);
156              
157 8         61 $fh = File::KDBX::IO::HashBlock->new($fh);
158              
159 8         28 my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
160 8 50       27 if ($compress == COMPRESSION_GZIP) {
    0          
161 8         36 load_optional('IO::Compress::Gzip');
162 8 50       48 $fh = IO::Compress::Gzip->new($fh,
163             -Level => IO::Compress::Gzip::Z_BEST_COMPRESSION(),
164             -TextFlag => 1,
165             ) or throw "Failed to initialize compression library: $IO::Compress::Gzip::GzipError",
166             error => $IO::Compress::Gzip::GzipError;
167             }
168             elsif ($compress != COMPRESSION_NONE) {
169 0         0 throw "Unsupported compression ($compress)\n", compression_flags => $compress;
170             }
171              
172 8         282 my $header_hash = digest_data('SHA256', $header_data);
173 8         62 $self->_write_inner_body($fh, $header_hash);
174             }
175              
176             1;
177              
178             __END__