Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/IO/HmacBlock.pm

   1 package File::KDBX::IO::HmacBlock;
   2 # ABSTRACT: HMAC block stream IO handle
   3
   4 use warnings;
   5 use strict;
   6
   7 use Crypt::Digest qw(digest_data);
   8 use Crypt::Mac::HMAC qw(hmac);
   9 use Errno;
  10 use File::KDBX::Error;
  11 use File::KDBX::Util qw(:io assert_64bit);
  12 use namespace::clean;
  13
  14 use parent 'File::KDBX::IO';
  15
  16 our $VERSION = '999.999'; # VERSION
  17 our $BLOCK_SIZE = 1048576;  # 1MiB
  18 our $ERROR;
  19
  20 =method new
  21
  22     $fh = File::KDBX::IO::HmacBlock->new(%attributes);
  23     $fh = File::KDBX::IO::HmacBlock->new($fh, %attributes);
  24
  25 Construct a new HMAC-block stream IO handle.
  26
  27 =cut
  28
  29 sub new {
  30     assert_64bit;
  31
  32     my $class = shift;
  33     my %args = @_ % 2 == 1 ? (fh => shift, @_) : @_;
  34     my $self = $class->SUPER::new;
  35     $self->_fh($args{fh}) or throw 'IO handle required';
  36     $self->key($args{key}) or throw 'Key required';
  37     $self->block_size($args{block_size});
  38     $self->_buffer;
  39     return $self;
  40 }
  41
  42 =attr block_size
  43
  44 Desired block size when writing (default: C<$File::KDBX::IO::HmacBlock::BLOCK_SIZE> or 1,048,576 bytes)
  45
  46 =attr key
  47
  48 HMAC-SHA256 key for authenticating the data stream (required)
  49
  50 =cut
  51
  52 my %ATTRS = (
  53     _block_index    => 0,
  54     _buffer         => \(my $buf = ''),
  55     _finished       => 0,
  56     block_size      => sub { $BLOCK_SIZE },
  57     key             => undef,
  58 );
  59 while (my ($attr, $default) = each %ATTRS) {
  60     no strict 'refs'; ## no critic (ProhibitNoStrict)
  61     *$attr = sub {
  62         my $self = shift;
  63         *$self->{$attr} = shift if @_;
  64         *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
  65     };
  66 }
  67
  68 sub _FILL {
  69     my ($self, $fh) = @_;
  70
  71     $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
  72     return if $self->_finished;
  73
  74     my $block = eval { $self->_read_hashed_block($fh) };
  75     if (my $err = $@) {
  76         $self->_set_error($err);
  77         return;
  78     }
  79     if (length($block) == 0) {
  80         $self->_finished(1);
  81         return;
  82     }
  83     return $block;
  84 }
  85
  86 sub _WRITE {
  87     my ($self, $buf, $fh) = @_;
  88
  89     $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self ($fh)\n";
  90     return 0 if $self->_finished;
  91
  92     ${*$self->{_buffer}} .= $buf;
  93
  94     $self->_FLUSH($fh);  # TODO only if autoflush?
  95
  96     return length($buf);
  97 }
  98
  99 sub _POPPED {
 100     my ($self, $fh) = @_;
 101
 102     $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self ($fh)\n";
 103     return if $self->_mode ne 'w';
 104
 105     $self->_FLUSH($fh);
 106     eval {
 107         $self->_write_next_hmac_block($fh);     # partial block with remaining content
 108         $self->_write_final_hmac_block($fh);    # terminating block
 109     };
 110     $self->_set_error($@) if $@;
 111 }
 112
 113 sub _FLUSH {
 114     my ($self, $fh) = @_;
 115
 116     $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self ($fh)\n";
 117     return if $self->_mode ne 'w';
 118
 119     eval {
 120         while ($self->block_size <= length(${*$self->{_buffer}})) {
 121             $self->_write_next_hmac_block($fh);
 122         }
 123     };
 124     if (my $err = $@) {
 125         $self->_set_error($err);
 126         return -1;
 127     }
 128
 129     return 0;
 130 }
 131
 132 sub _set_error {
 133     my $self = shift;
 134     $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
 135     if (exists &Errno::EPROTO) {
 136         $! = &Errno::EPROTO;
 137     }
 138     elsif (exists &Errno::EIO) {
 139         $! = &Errno::EIO;
 140     }
 141     $self->_error($ERROR = error(@_));
 142 }
 143
 144 ##############################################################################
 145
 146 sub _read_hashed_block {
 147     my $self = shift;
 148     my $fh = shift;
 149
 150     read_all $fh, my $hmac, 32 or throw 'Failed to read HMAC';
 151
 152     read_all $fh, my $packed_size, 4 or throw 'Failed to read HMAC block size';
 153     my ($size) = unpack('L<', $packed_size);
 154
 155     my $block = '';
 156     if (0 < $size) {
 157         read_all $fh, $block, $size
 158             or throw 'Failed to read HMAC block', index => $self->_block_index, size => $size;
 159     }
 160
 161     my $packed_index = pack('Q<', $self->_block_index);
 162     my $got_hmac = hmac('SHA256', $self->_hmac_key,
 163         $packed_index,
 164         $packed_size,
 165         $block,
 166     );
 167
 168     $hmac eq $got_hmac
 169         or throw 'Block authentication failed', index => $self->_block_index, got => $got_hmac, expected => $hmac;
 170
 171     *$self->{_block_index}++;
 172     return $block;
 173 }
 174
 175 sub _write_next_hmac_block {
 176     my $self    = shift;
 177     my $fh      = shift;
 178     my $buffer  = shift // $self->_buffer;
 179     my $allow_empty = shift;
 180
 181     my $size = length($$buffer);
 182     $size = $self->block_size if $self->block_size < $size;
 183     return 0 if $size == 0 && !$allow_empty;
 184
 185     my $block = '';
 186     $block = substr($$buffer, 0, $size, '') if 0 < $size;
 187
 188     my $packed_index = pack('Q<', $self->_block_index);
 189     my $packed_size  = pack('L<', $size);
 190     my $hmac = hmac('SHA256', $self->_hmac_key,
 191         $packed_index,
 192         $packed_size,
 193         $block,
 194     );
 195
 196     $fh->print($hmac, $packed_size, $block)
 197         or throw 'Failed to write HMAC block', hmac => $hmac, block_size => $size;
 198
 199     *$self->{_block_index}++;
 200     return 0;
 201 }
 202
 203 sub _write_final_hmac_block {
 204     my $self = shift;
 205     my $fh = shift;
 206
 207     $self->_write_next_hmac_block($fh, \'', 1);
 208 }
 209
 210 sub _hmac_key {
 211     my $self = shift;
 212     my $key = shift // $self->key;
 213     my $index = shift // $self->_block_index;
 214
 215     my $packed_index = pack('Q<', $index);
 216     my $hmac_key = digest_data('SHA512', $packed_index, $key);
 217     return $hmac_key;
 218 }
 219
 220 1;
 221 __END__
 222
 223 =head1 DESCRIPTION
 224
 225 Writing to a HMAC-block stream handle will transform the data into a series of blocks. An HMAC is calculated
 226 for each block and is included in the output.
 227
 228 Reading from a handle, each block will be verified and authenticated as the blocks are disassembled back into
 229 a data stream.
 230
 231 This format helps ensure data integrity and authenticity of KDBX4 files.
 232
 233 Each block is encoded thusly:
 234
 235 =for :list
 236 * HMAC - 32 bytes, calculated over [block index (increments starting with 0), block size and data]
 237 * Block size - Little-endian unsigned 32-bit (counting only the data)
 238 * Data - String of bytes
 239
 240 The terminating block is an empty block encoded as usual but block size is 0 and there is no data.
 241
 242 =cut