File Coverage

blib/lib/File/KDBX/Entry.pm

Criterion	Covered	Total	%
statement	417	448	93.0
branch	165	252	65.4
condition	123	198	62.1
subroutine	82	86	95.3
pod	48	50	96.0
total	835	1034	80.7

package File::KDBX::Entry;
# ABSTRACT: A KDBX database entry

use warnings;
use strict;

use Crypt::Misc 0.049 qw(decode_b64 encode_b32r);
use Devel::GlobalDestruction;
use Encode qw(encode);
use File::KDBX::Constants qw(:history :icon);
use File::KDBX::Error;
use File::KDBX::Util qw(:assert :class :coercion :erase :function :uri generate_uuid load_optional);
use Hash::Util::FieldHash;
use List::Util qw(any first sum0);
use Ref::Util qw(is_coderef is_hashref is_plain_hashref);
use Scalar::Util qw(blessed looks_like_number);
use Storable qw(dclone);
use Time::Piece 1.33;
use boolean;
use namespace::clean;

extends 'File::KDBX::Object';

our $VERSION = '0.906'; # VERSION

my $PLACEHOLDER_MAX_DEPTH = 10;
my %PLACEHOLDERS;
my %STANDARD_STRINGS = map { $_ => 1 } qw(Title UserName Password URL Notes);


sub uuid {
    my $self = shift;
    if (@_ || !defined $self->{uuid}) {
        my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_;
        my $old_uuid = $self->{uuid};
        my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid;
        for my $entry (@{$self->history}) {
            $entry->{uuid} = $uuid;
        }
        $self->_signal('uuid.changed', $uuid, $old_uuid) if defined $old_uuid && $self->is_current;
    }
    $self->{uuid};
}

# has uuid                    => sub { generate_uuid(printable => 1) };
has icon_id                 => ICON_PASSWORD,   coerce => \&to_icon_constant;
has custom_icon_uuid        => undef,           coerce => \&to_uuid;
has foreground_color        => '',              coerce => \&to_string;
has background_color        => '',              coerce => \&to_string;
has override_url            => '',              coerce => \&to_string;
has tags                    => '',              coerce => \&to_string;
has auto_type               => {};
has previous_parent_group   => undef,           coerce => \&to_uuid;
has quality_check           => true,            coerce => \&to_bool;
has strings                 => {};
has binaries                => {};
has times                   => {};
# has custom_data             => {};
# has history                 => [];

has last_modification_time  => sub { gmtime }, store => 'times', coerce => \&to_time;
has creation_time           => sub { gmtime }, store => 'times', coerce => \&to_time;
has last_access_time        => sub { gmtime }, store => 'times', coerce => \&to_time;
has expiry_time             => sub { gmtime }, store => 'times', coerce => \&to_time;
has expires                 => false,          store => 'times', coerce => \&to_bool;
has usage_count             => 0,              store => 'times', coerce => \&to_number;
has location_changed        => sub { gmtime }, store => 'times', coerce => \&to_time;

# has 'auto_type.auto_type_enabled'                   => true, coerce => \&to_bool;
has 'auto_type_obfuscation' => 0, path => 'auto_type.data_transfer_obfuscation',
    coerce => \&to_number;
has 'auto_type_default_sequence'          => '{USERNAME}{TAB}{PASSWORD}{ENTER}',
    path => 'auto_type.default_sequence', coerce => \&to_string;
has 'auto_type_associations'              => [], path => 'auto_type.associations';

my %ATTRS_STRINGS = (
    title                   => 'Title',
    username                => 'UserName',
    password                => 'Password',
    url                     => 'URL',
    notes                   => 'Notes',
);
while (my ($attr, $string_key) = each %ATTRS_STRINGS) {
    no strict 'refs'; ## no critic (ProhibitNoStrict)
    *{$attr} = sub { shift->string_value($string_key, @_) };
    *{"expand_${attr}"} = sub { shift->expand_string_value($string_key, @_) };
}

my @ATTRS = qw(uuid custom_data history auto_type_enabled);
sub _set_nonlazy_attributes {
    my $self = shift;
    $self->$_ for @ATTRS, keys %ATTRS_STRINGS, list_attributes(ref $self);
}

sub init {
    my $self = shift;
    my %args = @_;

    while (my ($key, $val) = each %args) {
        if (my $method = $self->can($key)) {
            $self->$method($val);
        }
        else {
            $self->string($key => $val);
        }
    }

    return $self;
}

##############################################################################


sub string {
    my $self = shift;
    my %args = @_     == 2 ? (key => shift, value => shift)
             : @_ % 2 == 1 ? (key => shift, @_) : @_;

    if (!defined $args{key} && !defined $args{value}) {
        my %standard = (value => 1, protect => 1);
        my @other_keys = grep { !$standard{$_} } keys %args;
        if (@other_keys == 1) {
            my $key = $args{key} = $other_keys[0];
            $args{value} = delete $args{$key};
        }
    }

    my $key = delete $args{key} or throw 'Must provide a string key to access';

    return $self->{strings}{$key} = $args{value} if is_plain_hashref($args{value});

    # Auto-vivify the standard strings.
    if (!exists $self->{strings}{$key} && $STANDARD_STRINGS{$key}) {
        $args{value} //= '';
        $args{protect} //= true if $self->_protect($key);
    }

    while (my ($field, $value) = each %args) {
        $self->{strings}{$key}{$field} = $value;
    }

    return $self->{strings}{$key};
}

### Get whether or not a standard string is configured to be protected
sub _protect {
    my $self = shift;
    my $key  = shift;
    return false if !$STANDARD_STRINGS{$key};
    if (my $kdbx = eval { $self->kdbx }) {
        my $protect = $kdbx->memory_protection($key);
        return $protect if defined $protect;
    }
    return $key eq 'Password';
}


sub string_value {
    my $self = shift;
    my $string = $self->string(@_) // return undef;
    return $string->{value};
}


sub _expand_placeholder {
    my $self = shift;
    my $placeholder = shift;
    my $arg = shift;

    require File::KDBX;

    my $placeholder_key = $placeholder;
    if (defined $arg) {
        $placeholder_key = $File::KDBX::PLACEHOLDERS{"${placeholder}:${arg}"} ? "${placeholder}:${arg}"
                                                                              : "${placeholder}:";
    }
    return if !defined $File::KDBX::PLACEHOLDERS{$placeholder_key};

    my $local_key = join('/', Hash::Util::FieldHash::id($self), $placeholder_key);
    local $PLACEHOLDERS{$local_key} = my $handler = $PLACEHOLDERS{$local_key} // do {
        my $handler = $File::KDBX::PLACEHOLDERS{$placeholder_key} or next;
        memoize recurse_limit($handler, $PLACEHOLDER_MAX_DEPTH, sub {
            alert "Detected deep recursion while expanding $placeholder placeholder",
                placeholder => $placeholder;
            return; # undef
        });
    };

    return $handler->($self, $arg, $placeholder);
}

sub _expand_string {
    my $self    = shift;
    my $str     = shift;

    my $expand = memoize $self->can('_expand_placeholder'), $self;

    # placeholders (including field references):
    $str =~ s!\{([^:\}]+)(?::([^\}]*))?\}!$expand->(uc($1), $2, @_) // $&!egi;

    # environment variables (alt syntax):
    my $vars = join('|', map { quotemeta($_) } keys %ENV);
    $str =~ s!\%($vars)\%!$expand->(ENV => $1, @_) // $&!eg;

    return $str;
}

sub expand_string_value {
    my $self = shift;
    my $str  = $self->string_peek(@_) // return undef;
    my $cleanup = erase_scoped $str;
    return $self->_expand_string($str);
}


sub other_strings {
    my $self    = shift;
    my $delim   = shift // "\n";

    my @strings = map { $self->string_value($_) } grep { !$STANDARD_STRINGS{$_} } sort keys %{$self->strings};
    return join($delim, @strings);
}


sub string_peek {
    my $self = shift;
    my $string = $self->string(@_);
    return defined $string->{value} ? $string->{value} : $self->kdbx->peek($string);
}

##############################################################################


sub add_auto_type_association {
    my $self        = shift;
    my $association = shift;
    push @{$self->auto_type_associations}, $association;
}


sub expand_keystroke_sequence {
    my $self = shift;
    my $association = shift;

    my $keys;
    if ($association) {
        $keys = is_hashref($association) && exists $association->{keystroke_sequence} ?
        $association->{keystroke_sequence} : defined $association ? $association : '';
    }

    $keys = $self->auto_type_default_sequence if !$keys;
    # TODO - Fall back to getting default sequence from parent group, which probably means we shouldn't be
    # setting a default value in the entry..

    return $self->_expand_string($keys);
}

##############################################################################


sub binary {
    my $self = shift;
    my %args = @_     == 2 ? (key => shift, value => shift)
             : @_ % 2 == 1 ? (key => shift, @_) : @_;

    if (!defined $args{key} && !defined $args{value}) {
        my %standard = (value => 1, protect => 1);
        my @other_keys = grep { !$standard{$_} } keys %args;
        if (@other_keys == 1) {
            my $key = $args{key} = $other_keys[0];
            $args{value} = delete $args{$key};
        }
    }

    my $key = delete $args{key} or throw 'Must provide a binary key to access';

    return $self->{binaries}{$key} = $args{value} if is_plain_hashref($args{value});

    assert { !defined $args{value} || !utf8::is_utf8($args{value}) };
    while (my ($field, $value) = each %args) {
        $self->{binaries}{$key}{$field} = $value;
    }
    return $self->{binaries}{$key};
}


sub binary_value {
    my $self = shift;
    my $binary = $self->binary(@_) // return undef;
    return $binary->{value};
}

##############################################################################


sub hmac_otp {
    my $self = shift;
    load_optional('Pass::OTP');

    my %params = ($self->_hotp_params, @_);
    return if !defined $params{type} || !defined $params{secret};

    $params{secret} = encode_b32r($params{secret}) if !$params{base32};
    $params{base32} = 1;

    my $otp = eval { Pass::OTP::otp(%params, @_) };
    if (my $err = $@) {
        throw 'Unable to generate HOTP', error => $err;
    }

    $self->_hotp_increment_counter($params{counter});

    return $otp;
}


sub time_otp {
    my $self = shift;
    load_optional('Pass::OTP');

    my %params = ($self->_totp_params, @_);
    return if !defined $params{type} || !defined $params{secret};

    $params{secret} = encode_b32r($params{secret}) if !$params{base32};
    $params{base32} = 1;

    my $otp = eval { Pass::OTP::otp(%params, @_) };
    if (my $err = $@) {
        throw 'Unable to generate TOTP', error => $err;
    }

    return $otp;
}


sub hmac_otp_uri { $_[0]->_otp_uri($_[0]->_hotp_params) }
sub time_otp_uri { $_[0]->_otp_uri($_[0]->_totp_params) }

sub _otp_uri {
    my $self = shift;
    my %params = @_;

    return if 4 != grep { defined } @params{qw(type secret issuer account)};
    return if $params{type} !~ /^[ht]otp$/i;

    my $label = delete $params{label};
    $params{$_} = uri_escape_utf8($params{$_}) for keys %params;

    my $type    = lc($params{type});
    my $issuer  = $params{issuer};
    my $account = $params{account};

    $label //= "$issuer:$account";

    my $secret = $params{secret};
    $secret = uc(encode_b32r($secret)) if !$params{base32};

    delete $params{algorithm} if defined $params{algorithm} && $params{algorithm} eq 'sha1';
    delete $params{period}    if defined $params{period} && $params{period} == 30;
    delete $params{digits}    if defined $params{digits} && $params{digits} == 6;
    delete $params{counter}   if defined $params{counter} && $params{counter} == 0;

    my $uri = "otpauth://$type/$label?secret=$secret&issuer=$issuer";

    if (defined $params{encoder}) {
        $uri .= "&encoder=$params{encoder}";
        return $uri;
    }
    $uri .= '&algorithm=' . uc($params{algorithm}) if defined $params{algorithm};
    $uri .= "&digits=$params{digits}"   if defined $params{digits};
    $uri .= "&counter=$params{counter}" if defined $params{counter};
    $uri .= "&period=$params{period}"   if defined $params{period};

    return $uri;
}

sub _hotp_params {
    my $self = shift;

    my %params = (
        type    => 'hotp',
        issuer  => $self->expand_title      || 'KDBX',
        account => $self->expand_username   || 'none',
        digits  => 6,
        counter => $self->string_value('HmacOtp-Counter') // 0,
        $self->_otp_secret_params('Hmac'),
    );
    return %params if $params{secret};

    my %otp_params = $self->_otp_params;
    return () if !$otp_params{secret} || $otp_params{type} ne 'hotp';

    # $otp_params{counter} = 0

    return (%params, %otp_params);
}

sub _totp_params {
    my $self = shift;

    my %algorithms = (
        'HMAC-SHA-1'    => 'sha1',
        'HMAC-SHA-256'  => 'sha256',
        'HMAC-SHA-512'  => 'sha512',
    );
    my %params = (
        type        => 'totp',
        issuer      => $self->expand_title      || 'KDBX',
        account     => $self->expand_username   || 'none',
        digits      => $self->string_value('TimeOtp-Length') // 6,
        algorithm   => $algorithms{$self->string_value('TimeOtp-Algorithm') || ''} || 'sha1',
        period      => $self->string_value('TimeOtp-Period') // 30,
        $self->_otp_secret_params('Time'),
    );
    return %params if $params{secret};

    my %otp_params = $self->_otp_params;
    return () if !$otp_params{secret} || $otp_params{type} ne 'totp';

    return (%params, %otp_params);
}

# KeePassXC style
sub _otp_params {
    my $self = shift;
    load_optional('Pass::OTP::URI');

    my $uri = $self->string_value('otp') || '';
    my %params;
    %params = Pass::OTP::URI::parse($uri) if $uri =~ m!^otpauth://!;
    return () if !$params{secret} || !$params{type};

    if (($params{encoder} // '') eq 'steam') {
        $params{digits} = 5;
        $params{chars}  = '23456789BCDFGHJKMNPQRTVWXY';
    }

    # Pass::OTP::URI doesn't provide the issuer and account separately, so get them from the label
    my ($issuer, $user) = split(':', $params{label} // ':', 2);
    $params{issuer}  //= uri_unescape_utf8($issuer);
    $params{account} //= uri_unescape_utf8($user);

    $params{algorithm}  = lc($params{algorithm}) if $params{algorithm};
    $params{counter}    = $self->string_value('HmacOtp-Counter') if $params{type} eq 'hotp';

    return %params;
}

sub _otp_secret_params {
    my $self = shift;
    my $type = shift // return ();

    my $secret_txt = $self->string_value("${type}Otp-Secret");
    my $secret_hex = $self->string_value("${type}Otp-Secret-Hex");
    my $secret_b32 = $self->string_value("${type}Otp-Secret-Base32");
    my $secret_b64 = $self->string_value("${type}Otp-Secret-Base64");

    my $count = grep { defined } ($secret_txt, $secret_hex, $secret_b32, $secret_b64);
    return () if $count == 0;
    alert "Found multiple ${type}Otp-Secret strings", count => $count if 1 < $count;

    return (secret => $secret_b32, base32 => 1) if defined $secret_b32;
    return (secret => decode_b64($secret_b64))  if defined $secret_b64;
    return (secret => pack('H*', $secret_hex))  if defined $secret_hex;
    return (secret => encode('UTF-8', $secret_txt));
}

sub _hotp_increment_counter {
    my $self    = shift;
    my $counter = shift // $self->string_value('HmacOtp-Counter') || 0;

    looks_like_number($counter) or throw 'HmacOtp-Counter value must be a number', value => $counter;
    my $next = $counter + 1;
    $self->string('HmacOtp-Counter', $next);
    return $next;
}

##############################################################################


sub size {
    my $self = shift;

    my $size = 0;

    # tags
    $size += length(encode('UTF-8', $self->tags // ''));

    # attributes (strings)
    while (my ($key, $string) = each %{$self->strings}) {
        next if !defined $string->{value};
        $size += length(encode('UTF-8', $key)) + length(encode('UTF-8', $string->{value} // ''));
    }

    # custom data
    while (my ($key, $item) = each %{$self->custom_data}) {
        next if !defined $item->{value};
        $size += length(encode('UTF-8', $key)) + length(encode('UTF-8', $item->{value} // ''));
    }

    # binaries
    while (my ($key, $binary) = each %{$self->binaries}) {
        next if !defined $binary->{value};
        my $value_len = utf8::is_utf8($binary->{value}) ? length(encode('UTF-8', $binary->{value}))
            : length($binary->{value});
        $size += length(encode('UTF-8', $key)) + $value_len;
    }

    # autotype associations
    for my $association (@{$self->auto_type->{associations} || []}) {
        $size += length(encode('UTF-8', $association->{window}))
            + length(encode('UTF-8', $association->{keystroke_sequence} // ''));
    }

    return $size;
}

##############################################################################

sub history {
    my $self = shift;
    my $entries = $self->{history} //= [];
    if (@$entries && !blessed($entries->[0])) {
        @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries;
    }
    assert { !any { !blessed $_ } @$entries };
    return $entries;
}


sub history_size {
    my $self = shift;
    return sum0 map { $_->size } @{$self->history};
}


sub prune_history {
    my $self = shift;
    my %args = @_;

    my $max_items = $args{max_items} // eval { $self->kdbx->history_max_items } // HISTORY_DEFAULT_MAX_ITEMS;
    my $max_size  = $args{max_size}  // eval { $self->kdbx->history_max_size }  // HISTORY_DEFAULT_MAX_SIZE;
    my $max_age   = $args{max_age}   // eval { $self->kdbx->maintenance_history_days } // HISTORY_DEFAULT_MAX_AGE;

    # history is ordered oldest to newest
    my $history = $self->history;

    my @removed;

    if (0 <= $max_items && $max_items < @$history) {
        push @removed, splice @$history, -$max_items;
    }

    if (0 <= $max_size) {
        my $current_size = $self->history_size;
        while ($max_size < $current_size) {
            push @removed, my $entry = shift @$history;
            $current_size -= $entry->size;
        }
    }

    if (0 <= $max_age) {
        my $cutoff = gmtime - ($max_age * 86400);
        for (my $i = @$history - 1; 0 <= $i; --$i) {
            my $entry = $history->[$i];
            next if $cutoff <= $entry->last_modification_time;
            push @removed, splice @$history, $i, 1;
        }
    }

    @removed = sort { $a->last_modification_time <=> $b->last_modification_time } @removed;
    return @removed;
}


sub add_historical_entry {
    my $self = shift;
    delete $_->{history} for @_;
    push @{$self->{history} //= []}, map { $self->_wrap_entry($_) } @_;
}


sub remove_historical_entry {
    my $self    = shift;
    my $entry   = shift;
    my $history = $self->history;

    my @removed;
    for (my $i = @$history - 1; 0 <= $i; --$i) {
        my $item = $history->[$i];
        next if Hash::Util::FieldHash::id($entry) != Hash::Util::FieldHash::id($item);
        push @removed, splice @{$self->{history}}, $i, 1;
    }
    return @removed;
}


sub current_entry {
    my $self    = shift;
    my $parent  = $self->group;

    if ($parent) {
        my $id = $self->uuid;
        my $entry = first { $id eq $_->uuid } @{$parent->entries};
        return $entry if $entry;
    }

    return $self;
}


sub is_current {
    my $self    = shift;
    my $current = $self->current_entry;
    return Hash::Util::FieldHash::id($self) == Hash::Util::FieldHash::id($current);
}


sub is_historical { !$_[0]->is_current }


sub remove {
    my $self    = shift;
    my $current = $self->current_entry;
    return $self if $current->remove_historical_entry($self);
    $self->SUPER::remove(@_);
}

##############################################################################


sub searching_enabled {
    my $self = shift;
    my $parent = $self->group;
    return $parent->effective_enable_searching if $parent;
    return true;
}

sub auto_type_enabled {
    my $self = shift;
    $self->auto_type->{enabled} = to_bool(shift) if @_;
    $self->auto_type->{enabled} //= true;
    return false if !$self->auto_type->{enabled};
    return true if !$self->is_connected;
    my $parent = $self->group;
    return $parent->effective_enable_auto_type if $parent;
    return true;
}

##############################################################################

sub _signal {
    my $self = shift;
    my $type = shift;
    return $self->SUPER::_signal("entry.$type", @_);
}

sub _commit {
    my $self = shift;
    my $orig = shift;
    $self->add_historical_entry($orig);
    my $time = gmtime;
    $self->last_modification_time($time);
    $self->last_access_time($time);
}

sub label { shift->expand_title(@_) }

### Name of the parent attribute expected to contain the object
sub _parent_container { 'entries' }

1;

__END__