view release on metacpan or  search on metacpan

lib/File/KeePass.pm  view on Meta::CPAN

    $buffer = $self->compress($buffer) if $head->{'compression'} eq '1';
    $buffer = $self->chunksum($buffer);

    substr $buffer, 0, 0, $head->{'start_bytes'};

    return $header . $self->encrypt_rijndael_cbc($buffer, $key, $head->{'enc_iv'});
}

sub _gen_v2_date {
    my ($self, $date) = @_;
    $date = $self->now($date) if !$date || $date =~ /^\d+$/;
    my ($year, $mon, $day, $hour, $min, $sec) = $date =~ $qr_date ? ($1,$2,$3,$4,$5,$6) : die "Invalid date ($date)";
    return "${year}-${mon}-${day}T${hour}:${min}:${sec}Z";
}

sub _gen_v2_header {
    my ($self, $head) = @_;
    $head->{'sig1'}        = DB_SIG_1;
    $head->{'sig2'}        = DB_SIG_2_v2;
    $head->{'ver'}         = DB_VER_DW_V2;
    $head->{'comment'}     = '' if ! defined $head->{'comment'};
    $head->{'compression'} = (!defined($head->{'compression'}) || $head->{'compression'} eq '1') ? 1 : 0;
    $head->{'0'}           ||= "\r\n\r\n";
    $head->{'protected_stream_key'} ||= join '', map {chr rand 256} 1..32;
    die "Missing start_bytes\n" if ! $head->{'start_bytes'};
    die "Length of $_ was not 32 (".length($head->{$_}).")\n" for grep {length($head->{$_}) != 32} qw(seed_rand seed_key protected_stream_key start_bytes);
    die "Length of enc_iv was not 16\n" if length($head->{'enc_iv'}) != 16;

    my $buffer = pack 'L3', @$head{qw(sig1 sig2 ver)};

    my $pack = sub { my ($type, $str) = @_; $buffer .= pack('C S', $type, length($str)) . $str };
    $pack->(1, $head->{'comment'}) if defined($head->{'comment'}) && length($head->{'comment'});
    $pack->(2, "\x31\xc1\xf2\xe6\xbf\x71\x43\x50\xbe\x58\x05\x21\x6a\xfc\x5a\xff"); # aes cipher
    $pack->(3, pack 'V', $head->{'compression'} ? 1 : 0);
    $pack->(4, $head->{'seed_rand'});
    $pack->(5, $head->{'seed_key'});
    $pack->(6, pack 'LL', $head->{'rounds'}, 0); # a little odd to be double the length but not used
    $pack->(7, $head->{'enc_iv'});
    $pack->(8, $head->{'protected_stream_key'});
    $pack->(9, $head->{'start_bytes'});
    $pack->(10, pack('V', 2)); # salsa20 protection
    $pack->(0, $head->{'0'});
    return $buffer;
}

###----------------------------------------------------------------###

sub slurp {
    my ($self, $file) = @_;
    open my $fh, '<', $file or die "Could not open $file: $!\n";
    my $size = -s $file || die "File $file appears to be empty.\n";
    binmode $fh;
    read($fh, my $buffer, $size);
    close $fh;
    die "Could not read entire file contents of $file.\n" if length($buffer) != $size;
    return $buffer;
}

sub decrypt_rijndael_cbc {
    my ($self, $buffer, $key, $enc_iv) = @_;
    #use Crypt::CBC; return Crypt::CBC->new(-cipher => 'Rijndael', -key => $key, -iv => $enc_iv, -regenerate_key => 0, -prepend_iv => 0)->decrypt($buffer);
    my $cipher = Crypt::Rijndael->new($key, Crypt::Rijndael::MODE_CBC());
    $cipher->set_iv($enc_iv);
    $buffer = $cipher->decrypt($buffer);
    my $extra = ord(substr $buffer, -1, 1);
    substr($buffer, length($buffer) - $extra, $extra, '');
    return $buffer;
}

sub encrypt_rijndael_cbc {
    my ($self, $buffer, $key, $enc_iv) = @_;
    #use Crypt::CBC; return Crypt::CBC->new(-cipher => 'Rijndael', -key => $key, -iv => $enc_iv, -regenerate_key => 0, -prepend_iv => 0)->encrypt($buffer);
    my $cipher = Crypt::Rijndael->new($key, Crypt::Rijndael::MODE_CBC());
    $cipher->set_iv($enc_iv);
    my $extra = (16 - length($buffer) % 16) || 16; # always pad so we can always trim
    $buffer .= chr($extra) for 1 .. $extra;
    return $cipher->encrypt($buffer);
}

sub unchunksum {
    my ($self, $buffer) = @_;
    my ($new, $pos) = ('', 0);
    while ($pos < length($buffer)) {
        my ($index, $hash, $size) = unpack "\@$pos L a32 i", $buffer;
        $pos += 40;
        if ($size == 0) {
            warn "Found mismatch for 0 chunksize\n" if $hash ne "\0"x32;
            last;
        }
        #print "$index $hash $size\n";
        my $chunk = substr $buffer, $pos, $size;
        die "Chunk hash of index $index did not match\n" if $hash ne sha256($chunk);
        $pos += $size;
        $new .= $chunk;
    }
    return $new;
}

sub chunksum {
    my ($self, $buffer) = @_;
    my $new;
    my $index = 0;
    my $chunk_size = 8192;
    my $pos = 0;
    while ($pos < length($buffer)) {
        my $chunk = substr($buffer, $pos, $chunk_size);
        $new .= pack "L a32 i", $index++, sha256($chunk), length($chunk);
        $new .= $chunk;
        $pos += length($chunk);
    }
    $new .= pack "L a32 i", $index++, "\0"x32, 0;
    return $new;
}

sub decompress {
    my ($self, $buffer) = @_;
    eval { require Compress::Raw::Zlib } or die "Cannot load compression library to decompress database: $@";
    my ($i, $status) = Compress::Raw::Zlib::Inflate->new(-WindowBits => 31);
    die "Failed to initialize inflator ($status)\n" if $status != Compress::Raw::Zlib::Z_OK();
    $status = $i->inflate($buffer, my $out);
    die "Failed to uncompress buffer ($status)\n" if $status != Compress::Raw::Zlib::Z_STREAM_END();
    return $out;
}

sub compress {
    my ($self, $buffer) = @_;
    eval { require Compress::Raw::Zlib } or die "Cannot load compression library to compress database: $@";
    my ($d, $status) = Compress::Raw::Zlib::Deflate->new(-WindowBits => 31, -AppendOutput => 1);
    die "Failed to initialize inflator ($status)\n" if $status != Compress::Raw::Zlib::Z_OK();
    $status = $d->deflate($buffer, my $out);
    die "Failed to compress buffer ($status)\n" if $status != Compress::Raw::Zlib::Z_OK();
    $status = $d->flush($out);
    die "Failed to compress buffer ($status).\n" if $status != Compress::Raw::Zlib::Z_OK();