Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/KDF/AES.pm

   1 package File::KDBX::KDF::AES;
   2 # ABSTRACT: Using the AES cipher as a key derivation function
   3
   4 use warnings;
   5 use strict;
   6
   7 use Crypt::Cipher;
   8 use Crypt::Digest qw(digest_data);
   9 use File::KDBX::Constants qw(:bool :kdf);
  10 use File::KDBX::Error;
  11 use File::KDBX::Util qw(:class :load can_fork);
  12 use namespace::clean;
  13
  14 extends 'File::KDBX::KDF';
  15
  16 our $VERSION = '999.999'; # VERSION
  17
  18 # Rounds higher than this are eligible for forking:
  19 my $FORK_OPTIMIZATION_THRESHOLD = 100_000;
  20
  21 BEGIN {
  22     my $use_fork = $ENV{NO_FORK} || !can_fork;
  23     *_USE_FORK = $use_fork ? \&TRUE : \&FALSE;
  24 }
  25
  26 =attr rounds
  27
  28     $rounds = $kdf->rounds;
  29
  30 Get the number of times to run the function during transformation.
  31
  32 =cut
  33
  34 sub rounds  { $_[0]->{+KDF_PARAM_AES_ROUNDS} || KDF_DEFAULT_AES_ROUNDS }
  35 sub seed    { $_[0]->{+KDF_PARAM_AES_SEED} }
  36
  37 sub init {
  38     my $self = shift;
  39     my %args = @_;
  40     return $self->SUPER::init(
  41         KDF_PARAM_AES_ROUNDS()  => $args{+KDF_PARAM_AES_ROUNDS} // $args{rounds},
  42         KDF_PARAM_AES_SEED()    => $args{+KDF_PARAM_AES_SEED}   // $args{seed},
  43     );
  44 }
  45
  46 sub _transform {
  47     my $self    = shift;
  48     my $key     = shift;
  49
  50     my $seed = $self->seed;
  51     my $rounds = $self->rounds;
  52
  53     length($key) == 32 or throw 'Raw key must be 32 bytes', size => length($key);
  54     length($seed) == 32 or throw 'Invalid seed length', size => length($seed);
  55
  56     my ($key_l, $key_r) = unpack('(a16)2', $key);
  57
  58     goto NO_FORK if !_USE_FORK || $rounds < $FORK_OPTIMIZATION_THRESHOLD;
  59     {
  60         my $pid = open(my $read, '-|') // do { alert "fork failed: $!"; goto NO_FORK };
  61         if ($pid == 0) { # child
  62             my $l = _transform_half($seed, $key_l, $rounds);
  63             require POSIX;
  64             print $l or POSIX::_exit(1);
  65             POSIX::_exit(0);
  66         }
  67         my $r = _transform_half($seed, $key_r, $rounds);
  68         read($read, my $l, length($key_l)) == length($key_l) or do { alert "read failed: $!", goto NO_FORK };
  69         close($read) or do { alert "worker thread exited abnormally", status => $?; goto NO_FORK };
  70         return digest_data('SHA256', $l, $r);
  71     }
  72
  73     # FIXME: This used to work but now it crashes frequently. Threads are now discouraged anyway, but it might
  74     # be nice if this was available for no-fork platforms.
  75     # if ($ENV{THREADS} && eval 'use threads; 1') {
  76     #     my $l = threads->create(\&_transform_half, $key_l, $seed, $rounds);
  77     #     my $r = _transform_half($key_r, $seed, $rounds);
  78     #     return digest_data('SHA256', $l->join, $r);
  79     # }
  80
  81     NO_FORK:
  82     my $l = _transform_half($seed, $key_l, $rounds);
  83     my $r = _transform_half($seed, $key_r, $rounds);
  84     return digest_data('SHA256', $l, $r);
  85 }
  86
  87 sub _transform_half_pp {
  88     my $seed    = shift;
  89     my $key     = shift;
  90     my $rounds  = shift;
  91
  92     my $c = Crypt::Cipher->new('AES', $seed);
  93
  94     my $result = $key;
  95     for (my $i = 0; $i < $rounds; ++$i) {
  96         $result = $c->encrypt($result);
  97     }
  98
  99     return $result;
 100 }
 101
 102 BEGIN {
 103     my $use_xs = load_xs;
 104     *_transform_half = $use_xs ? \&File::KDBX::XS::kdf_aes_transform_half : \&_transform_half_pp;
 105 }
 106
 107 1;
 108 __END__
 109
 110 =head1 DESCRIPTION
 111
 112 An AES-256-based key derivation function. This is a L<File::KDBX::KDF> subclass.
 113
 114 This KDF has a long, solid track record. It is supported in both KDBX3 and KDBX4.
 115
 116 =head1 CAVEATS
 117
 118 This module can be pretty slow when the number of rounds is high. If you have L<File::KDBX::XS>, that will
 119 help. If your perl has C<fork>, that will also help. If you need to turn off one or both of these
 120 optimizations for some reason, set the C<PERL_ONLY> (to prevent Loading C<File::KDBX::XS>) and C<NO_FORK>
 121 environment variables.
 122
 123 =cut