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

   1 package PerlIO::via::File::KDBX::HmacBlock;
   2 # ABSTRACT: HMAC block-stream PerlIO layer
   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 our $VERSION = '999.999'; # VERSION
  15 our $BLOCK_SIZE = 1048576;
  16 our $ERROR;
  17
  18 =method push
  19
  20     PerlIO::via::File::KDBX::HmacBlock->push($fh, key => $key);
  21     PerlIO::via::File::KDBX::HmacBlock->push($fh, key => $key, block_size => $size);
  22
  23 Push a new HMAC-block layer with arguments. A key is required.
  24
  25 B<WARNING:> You mustn't push this layer using C<binmode> directly because the layer needs to be initialized
  26 with the key and any other desired attributes.
  27
  28 B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using
  29 C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data
  30 before the filehandle closes so it can write the final block (which will likely be shorter than the other
  31 blocks), and the way to indicate that is by popping the layer.
  32
  33 =cut
  34
  35 my %PUSHED_ARGS;
  36 sub push {
  37     assert_64bit;
  38
  39     %PUSHED_ARGS and throw 'Pushing HmacBlock layer would stomp existing arguments';
  40
  41     my $class = shift;
  42     my $fh = shift;
  43     my %args = @_ % 2 == 0 ? @_ : (key => @_);
  44     $args{key} or throw 'Must pass a key';
  45
  46     my $key_size = length($args{key});
  47     $key_size == 64 or throw 'Key must be 64 bytes in length', size => $key_size;
  48
  49     %PUSHED_ARGS = %args;
  50     binmode($fh, ':via(' . __PACKAGE__ . ')');
  51 }
  52
  53 sub PUSHED {
  54     my ($class, $mode) = @_;
  55
  56     %PUSHED_ARGS or throw 'Programmer error: Use PerlIO::via::File::KDBX::HmacBlock->push instead of binmode';
  57
  58     $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class (mode: $mode)\n";
  59     my $self = bless {
  60         block_index => 0,
  61         block_size  => $PUSHED_ARGS{block_size} || $BLOCK_SIZE,
  62         buffer      => \(my $buf = ''),
  63         key         => $PUSHED_ARGS{key},
  64         mode        => $mode,
  65     }, $class;
  66     %PUSHED_ARGS = ();
  67     return $self;
  68 }
  69
  70 sub FILL {
  71     my ($self, $fh) = @_;
  72
  73     $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
  74     return if $self->EOF($fh);
  75
  76     my $block = eval { $self->_read_hashed_block($fh) };
  77     if (my $err = $@) {
  78         $self->_set_error($err);
  79         return;
  80     }
  81     if (length($block) == 0) {
  82         $self->{eof} = 1;
  83         return;
  84     }
  85     return $block;
  86 }
  87
  88 sub WRITE {
  89     my ($self, $buf, $fh) = @_;
  90
  91     $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
  92     return 0 if $self->EOF($fh);
  93
  94     ${$self->{buffer}} .= $buf;
  95
  96     $self->FLUSH($fh);
  97
  98     return length($buf);
  99 }
 100
 101 sub POPPED {
 102     my ($self, $fh) = @_;
 103
 104     $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
 105     return if $self->mode !~ /^w/;
 106
 107     $self->FLUSH($fh);
 108     eval {
 109         $self->_write_next_hmac_block($fh);     # partial block with remaining content
 110         $self->_write_final_hmac_block($fh);    # terminating block
 111     };
 112     $self->_set_error($@) if $@;
 113 }
 114
 115 sub FLUSH {
 116     my ($self, $fh) = @_;
 117
 118     $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
 119     return 0 if !ref $self;
 120
 121     eval {
 122         while ($self->block_size <= length(${$self->{buffer}})) {
 123             $self->_write_next_hmac_block($fh);
 124         }
 125     };
 126     if (my $err = $@) {
 127         $self->_set_error($err);
 128         return -1;
 129     }
 130
 131     return 0;
 132 }
 133
 134 sub EOF {
 135     $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
 136     $_[0]->{eof} || $_[0]->ERROR($_[1]);
 137 }
 138 sub ERROR {
 139     $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
 140     $ERROR = $_[0]->{error} if $_[0]->{error};
 141     $_[0]->{error} ? 1 : 0;
 142 }
 143 sub CLEARERR {
 144     $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n";
 145     # delete $_[0]->{error};
 146 }
 147
 148 =attr key
 149
 150     $key = $hmac_block->key;
 151
 152 Get the key used for authentication. The key must be exactly 64 bytes in size.
 153
 154 =cut
 155
 156 sub key { $_[0]->{key} or throw 'Key is not set' }
 157
 158 =attr block_size
 159
 160     $size = $hmac_block->block_size;
 161
 162 Get the block size. Default is C<$PerlIO::via::File::KDBX::HmacBlock::BLOCK_SIZE>.
 163
 164 This only matters in write mode. When reading, block size is detected from the stream.
 165
 166 =cut
 167
 168 sub block_size  { $_[0]->{block_size} ||= $BLOCK_SIZE }
 169
 170 =attr block_index
 171
 172 =attr buffer
 173
 174 =attr mode
 175
 176 Internal attributes.
 177
 178 =cut
 179
 180 sub block_index { $_[0]->{block_index} ||= 0 }
 181 sub buffer      { $_[0]->{buffer} }
 182 sub mode        { $_[0]->{mode} }
 183
 184 sub _read_hashed_block {
 185     my $self = shift;
 186     my $fh = shift;
 187
 188     read_all $fh, my $hmac, 32 or throw 'Failed to read HMAC';
 189
 190     read_all $fh, my $size_buf, 4 or throw 'Failed to read HMAC block size';
 191     my ($size) = unpack('L<', $size_buf);
 192
 193     my $block = '';
 194     if (0 < $size) {
 195         read_all $fh, $block, $size
 196             or throw 'Failed to read HMAC block', index => $self->block_index, size => $size;
 197     }
 198
 199     my $index_buf = pack('Q<', $self->block_index);
 200     my $got_hmac = hmac('SHA256', $self->_hmac_key,
 201         $index_buf,
 202         $size_buf,
 203         $block,
 204     );
 205
 206     $hmac eq $got_hmac
 207         or throw 'Block authentication failed', index => $self->block_index, got => $got_hmac, expected => $hmac;
 208
 209     $self->{block_index}++;
 210
 211     return $block;
 212 }
 213
 214 sub _write_next_hmac_block {
 215     my $self    = shift;
 216     my $fh      = shift;
 217     my $buffer  = shift // $self->buffer;
 218     my $allow_empty = shift;
 219
 220     my $size = length($$buffer);
 221     $size = $self->block_size if $self->block_size < $size;
 222     return 0 if $size == 0 && !$allow_empty;
 223
 224     my $block = '';
 225     $block = substr($$buffer, 0, $size, '') if 0 < $size;
 226
 227     my $index_buf = pack('Q<', $self->block_index);
 228     my $size_buf = pack('L<', $size);
 229     my $hmac = hmac('SHA256', $self->_hmac_key,
 230         $index_buf,
 231         $size_buf,
 232         $block,
 233     );
 234
 235     print $fh $hmac, $size_buf, $block
 236         or throw 'Failed to write HMAC block', hmac => $hmac, block_size => $size, err => $fh->error;
 237
 238     $self->{block_index}++;
 239     return 0;
 240 }
 241
 242 sub _write_final_hmac_block {
 243     my $self = shift;
 244     my $fh = shift;
 245
 246     $self->_write_next_hmac_block($fh, \'', 1);
 247 }
 248
 249 sub _hmac_key {
 250     my $self = shift;
 251     my $key = shift // $self->key;
 252     my $index = shift // $self->block_index;
 253
 254     my $index_buf = pack('Q<', $index);
 255     my $hmac_key = digest_data('SHA512', $index_buf, $key);
 256     return $hmac_key;
 257 }
 258
 259 sub _set_error {
 260     my $self = shift;
 261     $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
 262     if (exists &Errno::EPROTO) {
 263         $! = &Errno::EPROTO;
 264     }
 265     elsif (exists &Errno::EIO) {
 266         $! = &Errno::EIO;
 267     }
 268     $self->{error} = $ERROR = File::KDBX::Error->new(@_);
 269 }
 270
 271 1;
 272 __END__
 273
 274 =head1 DESCRIPTION
 275
 276 Writing to a handle with this layer will transform the data in a series of blocks. An HMAC is calculated for
 277 each block and is included in the output.
 278
 279 Reading from a handle, each block will be verified and authenticated as the blocks are disassembled back into
 280 a data stream.
 281
 282 Each block is encoded thusly:
 283
 284 =for :list
 285 * HMAC - 32 bytes, calculated over [block index (increments starting with 0), block size and data]
 286 * Block size - Little-endian unsigned 32-bit (counting only the data)
 287 * Data - String of bytes
 288
 289 The terminating block is an empty block encoded as usual but block size is 0 and there is no data.
 290
 291 =cut