From: Charles McGarvey Date: Sat, 16 Apr 2022 07:21:21 +0000 (-0600) Subject: Add key file saving and refactor some stuff X-Git-Tag: v0.800~32 X-Git-Url: https://git.dogcows.com/gitweb?a=commitdiff_plain;h=1b913e5c8826cae2355b0076ec5701aa3ce63c63;p=chaz%2Fp5-File-KDBX Add key file saving and refactor some stuff --- diff --git a/dist.ini b/dist.ini index 7d864d7..9344c9c 100644 --- a/dist.ini +++ b/dist.ini @@ -13,7 +13,6 @@ no_index = lib/PerlIO/via/File/KDBX t xt ; B::COW might speed up the memory erase feature, maybe B::COW = 0 File::Spec = 0 -File::Which = 0 [Prereqs / TestSuggests] POSIX::1003 = 0 diff --git a/lib/File/KDBX.pm b/lib/File/KDBX.pm index 03a055b..2dcf341 100644 --- a/lib/File/KDBX.pm +++ b/lib/File/KDBX.pm @@ -107,12 +107,13 @@ sub STORABLE_freeze { my $copy = {%$self}; - return '', $copy, $KEYS{refaddr($self)}, $SAFE{refaddr($self)}; + return '', $copy, $KEYS{refaddr($self)} // (), $SAFE{refaddr($self)} // (); } sub STORABLE_thaw { my $self = shift; my $cloning = shift; + shift; my $clone = shift; my $key = shift; my $safe = shift; @@ -120,6 +121,10 @@ sub STORABLE_thaw { @$self{keys %$clone} = values %$clone; $KEYS{refaddr($self)} = $key; $SAFE{refaddr($self)} = $safe; + + for my $object (@{$self->all_groups}, @{$self->all_entries(history => 1)}) { + $object->kdbx($self); + } } ############################################################################## @@ -456,7 +461,7 @@ sub minimum_version { return KDBX_VERSION_4_1 if any { nonempty $_->previous_parent_group || (defined $_->quality_check && !$_->quality_check) || any { nonempty $_->{last_modification_time} } values %{$_->custom_data} - } @{$self->all_entries}; + } @{$self->all_entries(history => 1)}; return KDBX_VERSION_4_0 if $self->kdf->uuid ne KDF_UUID_AES; @@ -464,7 +469,7 @@ sub minimum_version { return KDBX_VERSION_4_0 if any { nonempty $_->custom_data - } @{$self->all_groups}, @{$self->all_entries}; + } @{$self->all_groups}, @{$self->all_entries(history => 1)}; return KDBX_VERSION_3_1; } @@ -473,6 +478,14 @@ sub minimum_version { =method add_group + $kdbx->add_group($group, %options); + $kdbx->add_group(%group_attributes, %options); + +Add a group to a database. This is equivalent to identifying a parent group and calling +L on the parent group, forwarding the arguments. Available options: + +=for :list +* C (aka C) - Group (object or group UUID) to add the group to (default: root group) =cut @@ -481,16 +494,15 @@ sub add_group { my $group = @_ % 2 == 1 ? shift : undef; my %args = @_; + # find the right group to add the group to my $parent = delete $args{group} // delete $args{parent} // $self->root; ($parent) = $self->find_groups({uuid => $parent}) if !ref $parent; + $parent or throw 'Invalid group'; - $group = $self->_group($group // [%args]); - $group->uuid; - - return $parent->add_group($group); + return $parent->add_group(defined $group ? $group : (), %args, kdbx => $self); } -sub _group { +sub _wrap_group { my $self = shift; my $group = shift; require File::KDBX::Group; @@ -519,20 +531,20 @@ replace the root group, you are essentially replacing the entire database conten sub root { my $self = shift; if (@_) { - $self->{root} = $self->_group(@_); + $self->{root} = $self->_wrap_group(@_); $self->{root}->kdbx($self); } $self->{root} //= $self->_implicit_root; - return $self->_group($self->{root}); + return $self->_wrap_group($self->{root}); } sub _kpx_groups { my $self = shift; return [] if !$self->{root}; - return $self->_is_implicit_root ? $self->root->groups : [$self->root]; + return $self->_has_implicit_root ? $self->root->groups : [$self->root]; } -sub _is_implicit_root { +sub _has_implicit_root { my $self = shift; my $root = $self->root; my $temp = __PACKAGE__->_implicit_root; @@ -561,36 +573,6 @@ sub _implicit_root { ); } -=method group_level - - $level = $kdbx->group_level($group); - $level = $kdbx->group_level($group_uuid); - -Determine the depth/level of a group. The root group is level 0, its direct children are level 1, etc. - -=cut - -sub group_level { - my $self = shift; - my $group = $self->_group(shift); - my $uuid = !is_ref($group) ? $group : $group->uuid; # FIXME can't check if it's a UUID after running - # through _group - return _group_level($uuid, $self->root, 0); -} - -sub _group_level { - my ($uuid, $base, $level) = @_; - - return $level if $uuid eq $base->{uuid}; - - for my $subgroup (@{$base->{groups} || []}) { - my $result = _group_level($uuid, $subgroup, $level + 1); - return $result if 0 <= $result; - } - - return -1; -} - =method all_groups \@groups = $kdbx->all_groups(%options); @@ -610,7 +592,7 @@ sub all_groups { my %args = @_ % 2 == 0 ? @_ : (base => shift, @_); my $base = $args{base} // $self->root; - my @groups = $args{include_base} // 1 ? $self->_group($base) : (); + my @groups = $args{include_base} // 1 ? $self->_wrap_group($base) : (); for my $subgroup (@{$base->{groups} || []}) { my $more = $self->all_groups($subgroup); @@ -635,17 +617,23 @@ the database structure. sub trace_lineage { my $self = shift; - my $thing = shift; + my $object = shift; + return $object->lineage(@_); +} + +sub _trace_lineage { + my $self = shift; + my $object = shift; my @lineage = @_; push @lineage, $self->root if !@lineage; - my $base = $lineage[-1]; + my $base = $lineage[-1] or return []; - my $uuid = $thing->uuid; + my $uuid = $object->uuid; return \@lineage if any { $_->uuid eq $uuid } @{$base->groups || []}, @{$base->entries || []}; for my $subgroup (@{$base->groups || []}) { - my $result = $self->trace_lineage($thing, @lineage, $subgroup); + my $result = $self->_trace_lineage($object, @lineage, $subgroup); return $result if $result; } } @@ -680,6 +668,14 @@ sub remove { =method add_entry + $kdbx->add_entry($entry, %options); + $kdbx->add_entry(%entry_attributes, %options); + +Add a entry to a database. This is equivalent to identifying a parent group and calling +L on the parent group, forwarding the arguments. Available options: + +=for :list +* C (aka C) - Group (object or group UUID) to add the entry to (default: root group) =cut @@ -688,16 +684,15 @@ sub add_entry { my $entry = @_ % 2 == 1 ? shift : undef; my %args = @_; + # find the right group to add the entry to my $parent = delete $args{group} // delete $args{parent} // $self->root; ($parent) = $self->find_groups({uuid => $parent}) if !ref $parent; + $parent or throw 'Invalid group'; - $entry = $self->_entry($entry // delete $args{entry} // [%args]); - $entry->uuid; - - return $parent->add_entry($entry); + return $parent->add_entry(defined $entry ? $entry : (), %args, kdbx => $self); } -sub _entry { +sub _wrap_entry { my $self = shift; my $entry = shift; require File::KDBX::Entry; @@ -734,7 +729,7 @@ sub all_entries { my @entries; if ((!$search || $enable_searching) && (!$auto_type || $enable_auto_type)) { push @entries, - map { $self->_entry($_) } + map { $self->_wrap_entry($_) } grep { !$auto_type || $_->{auto_type}{enabled} } map { $_, $history ? @{$_->{history} || []} : () } @{$base->{entries} || []}; @@ -772,10 +767,10 @@ sub find_entries { my $query = shift or throw 'Must provide a query'; my %args = @_; my %all_entries = ( - base => $args{base}, - auto_type => $args{auto_type}, - search => $args{search}, - history => $args{history}, + base => $args{base}, + auto_type => $args{auto_type}, + search => $args{search}, + history => $args{history}, ); return @{search($self->all_entries(%all_entries), is_arrayref($query) ? @$query : $query)}; } @@ -1099,15 +1094,15 @@ our %PLACEHOLDERS = ( 'URL:PASSWORD' => sub { (split_url($_[0]->url))[8] }, 'UUID' => sub { local $_ = format_uuid($_[0]->uuid); s/-//g; $_ }, 'REF:' => sub { $_[0]->kdbx->resolve_reference($_[1]) }, - 'INTERNETEXPLORER' => sub { load_optional('File::Which'); File::Which::which('iexplore') }, - 'FIREFOX' => sub { load_optional('File::Which'); File::Which::which('firefox') }, - 'GOOGLECHROME' => sub { load_optional('File::Which'); File::Which::which('google-chrome') }, - 'OPERA' => sub { load_optional('File::Which'); File::Which::which('opera') }, - 'SAFARI' => sub { load_optional('File::Which'); File::Which::which('safari') }, + 'INTERNETEXPLORER' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('iexplore') }, + 'FIREFOX' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('firefox') }, + 'GOOGLECHROME' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('google-chrome') }, + 'OPERA' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('opera') }, + 'SAFARI' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('safari') }, 'APPDIR' => sub { load_optional('FindBin'); $FindBin::Bin }, - 'GROUP' => sub { $_[0]->parent->name }, + 'GROUP' => sub { my $p = $_[0]->parent; $p ? $p->name : undef }, 'GROUP_PATH' => sub { $_[0]->path }, - 'GROUP_NOTES' => sub { $_[0]->parent->notes }, + 'GROUP_NOTES' => sub { my $p = $_[0]->parent; $p ? $p->notes : undef }, # 'GROUP_SEL' # 'GROUP_SEL_PATH' # 'GROUP_SEL_NOTES' @@ -1659,7 +1654,7 @@ sub TO_JSON { +{%{$_[0]}} } 1; __END__ -=for Pod::Coverage TO_JSON +=for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON =head1 SYNOPSIS diff --git a/lib/File/KDBX/Entry.pm b/lib/File/KDBX/Entry.pm index c3ddcb9..c4c67b7 100644 --- a/lib/File/KDBX/Entry.pm +++ b/lib/File/KDBX/Entry.pm @@ -26,6 +26,8 @@ my $PLACEHOLDER_MAX_DEPTH = 10; my %PLACEHOLDERS; my %STANDARD_STRINGS = map { $_ => 1 } qw(Title UserName Password URL Notes); +sub _parent_container { 'entries' } + =attr uuid 128-bit UUID identifying the entry within the database. @@ -252,8 +254,6 @@ sub init { return $self; } -sub label { shift->title(@_) } - ############################################################################## =method string @@ -269,10 +269,11 @@ structure. For example: $string = { value => 'Password', - protect => true, + protect => true, # optional }; -Every string should have a value and these optional flags which might exist: +Every string should have a value (but might be C due to memory protection) and these optional flags +which might exist: =for :list * C - Whether or not the string value should be memory-protected. @@ -281,10 +282,6 @@ Every string should have a value and these optional flags which might exist: sub string { my $self = shift; - # use Data::Dumper; - # $self->{strings} = shift if @_ == 1 && is_plain_hashref($_[0]); - # return $self->{strings} //= {} if !@_; - my %args = @_ == 2 ? (key => shift, value => shift) : @_ % 2 == 1 ? (key => shift, @_) : @_; @@ -461,6 +458,11 @@ sub binary_value { return $binary->{value}; } +sub auto_type_enabled { + my $entry = shift; + # TODO +} + ############################################################################## =method hmac_otp @@ -738,7 +740,10 @@ sub size { sub history { my $self = shift; - return [map { __PACKAGE__->wrap($_, $self->kdbx) } @{$self->{history} || []}]; + my $entries = $self->{history} //= []; + # FIXME - Looping through entries on each access is too expensive. + @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries; + return $entries; } =method history_size @@ -759,7 +764,7 @@ sub history_size { $entry->prune_history(%options); Remove as many older historical entries as necessary to get under the database limits. The limits are taken -from the database or can be specified with C<%options>: +from the associated database (if any) or can be overridden with C<%options>: =for :list * C - Maximum number of historical entries to keep (default: 10, no limit: -1) @@ -795,7 +800,7 @@ sub prune_history { sub add_history { my $self = shift; delete $_->{history} for @_; - push @{$self->{history} //= []}, @_; + push @{$self->{history} //= []}, map { $self->_wrap_entry($_) } @_; } ############################################################################## @@ -813,7 +818,7 @@ sub _commit { $self->last_modification_time(gmtime); } -sub TO_JSON { +{%{$_[0]}} } +sub label { shift->expanded_title(@_) } 1; __END__ @@ -840,14 +845,14 @@ the attributes to see what's available. =head2 Placeholders -Entry strings and auto-type key sequences can have placeholders or template tags that can be replaced by other +Entry string and auto-type key sequences can have placeholders or template tags that can be replaced by other values. Placeholders can appear like C<{PLACEHOLDER}>. For example, a B string might have a value of C. C<{USERNAME}> is a placeholder for the value of the B string of the same entry. If the C string had a value of "batman", the B string would expand to C. -Some placeholders take an argument, where the argument follows the tag after a colon. The syntax for this is -C<{PLACEHOLDER:ARGUMENT}>. +Some placeholders take an argument, where the argument follows the tag after a colon but before the closing +brace, like C<{PLACEHOLDER:ARGUMENT}>. Placeholders are documented in the L. This software supports many (but not all) of the placeholders documented there. @@ -872,7 +877,7 @@ This software supports many (but not all) of the placeholders documented there. * ☑ C<{URL:RMVSCM}> / C<{URL:WITHOUTSCHEME}> * ☑ C<{S:Name}> - Custom string where C is the name or key of the string * ☑ C<{UUID}> - Identifier (32 hexidecimal characters) -* ☑ C<{HMACOTP}> - Generate an HMAC-based one-time password +* ☑ C<{HMACOTP}> - Generate an HMAC-based one-time password (its counter B be incremented) * ☑ C<{TIMEOTP}> - Generate a time-based one-time password * ☑ C<{GROUP_NOTES}> - Notes of the parent group * ☑ C<{GROUP_PATH}> - Full path of the parent group diff --git a/lib/File/KDBX/Group.pm b/lib/File/KDBX/Group.pm index 733e931..3aa562a 100644 --- a/lib/File/KDBX/Group.pm +++ b/lib/File/KDBX/Group.pm @@ -10,7 +10,7 @@ use File::KDBX::Error; use File::KDBX::Util qw(generate_uuid); use List::Util qw(sum0); use Ref::Util qw(is_ref); -use Scalar::Util qw(blessed); +use Scalar::Util qw(blessed refaddr); use Time::Piece; use boolean; use namespace::clean; @@ -19,6 +19,8 @@ use parent 'File::KDBX::Object'; our $VERSION = '999.999'; # VERSION +sub _parent_container { 'groups' } + my @ATTRS = qw(uuid custom_data entries groups); my %ATTRS = ( # uuid => sub { generate_uuid(printable => 1) }, @@ -82,62 +84,127 @@ sub uuid { $self->{uuid}; } -sub label { shift->name(@_) } +############################################################################## sub entries { my $self = shift; my $entries = $self->{entries} //= []; - require File::KDBX::Entry; - @$entries = map { File::KDBX::Entry->wrap($_, $self->kdbx) } @$entries; + # FIXME - Looping through entries on each access is too expensive. + @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries; return $entries; } -sub groups { +sub all_entries { my $self = shift; - my $groups = $self->{groups} //= []; - @$groups = map { File::KDBX::Group->wrap($_, $self->kdbx) } @$groups; - return $groups; + # FIXME - shouldn't have to delegate to the database to get this + return $self->kdbx->all_entries(base => $self); } -sub _kpx_groups { shift->groups(@_) } +=method add_entry -sub all_groups { + $entry = $group->add_entry($entry); + $entry = $group->add_entry(%entry_attributes); + +Add an entry to a group. If C<$entry> already has a parent group, it will be removed from that group before +being added to C<$group>. + +=cut + +sub add_entry { my $self = shift; - return $self->kdbx->all_groups(base => $self, include_base => false); + my $entry = @_ % 2 == 1 ? shift : undef; + my %args = @_; + + my $kdbx = delete $args{kdbx} // eval { $self->kdbx }; + + $entry = $self->_wrap_entry($entry // [%args]); + $entry->uuid; + $entry->kdbx($kdbx) if $kdbx; + + push @{$self->{entries} ||= []}, $entry->remove; + return $entry->_set_group($self); } -sub all_entries { +sub remove_entry { my $self = shift; - return $self->kdbx->all_entries(base => $self); + my $uuid = is_ref($_[0]) ? $self->_wrap_entry(shift)->uuid : shift; + my $objects = $self->{entries}; + for (my $i = 0; $i < @$objects; ++$i) { + my $o = $objects->[$i]; + next if $uuid ne $o->uuid; + return splice @$objects, $i, 1; + $o->_set_group(undef); + return @$objects, $i, 1; + } } -sub _group { - my $self = shift; - my $group = shift; - return File::KDBX::Group->wrap($group, $self); -} +############################################################################## -sub _entry { - my $self = shift; - my $entry = shift; - require File::KDBX::Entry; - return File::KDBX::Entry->wrap($entry, $self); +sub groups { + my $self = shift; + my $groups = $self->{groups} //= []; + # FIXME - Looping through groups on each access is too expensive. + @$groups = map { $self->_wrap_group($_, $self->kdbx) } @$groups; + return $groups; } -sub add_entry { +sub all_groups { my $self = shift; - my $entry = shift; - push @{$self->{entries} ||= []}, $entry; - return $entry; + # FIXME - shouldn't have to delegate to the database to get this + return $self->kdbx->all_groups(base => $self, include_base => false); } +sub _kpx_groups { shift->groups(@_) } + +=method add_group + + $new_group = $group->add_group($new_group); + $new_group = $group->add_group(%group_attributes); + +Add a group to a group. If C<$new_group> already has a parent group, it will be removed from that group before +being added to C<$group>. + +=cut + sub add_group { + my $self = shift; + my $group = @_ % 2 == 1 ? shift : undef; + my %args = @_; + + my $kdbx = delete $args{kdbx} // eval { $self->kdbx }; + + $group = $self->_wrap_group($group // [%args]); + $group->uuid; + $group->kdbx($kdbx) if $kdbx; + + push @{$self->{groups} ||= []}, $group->remove; + return $group->_set_group($self); +} + +sub remove_group { my $self = shift; - my $group = shift; - push @{$self->{groups} ||= []}, $group; - return $group; + my $uuid = is_ref($_[0]) ? $self->_wrap_group(shift)->uuid : shift; + my $objects = $self->{groups}; + for (my $i = 0; $i < @$objects; ++$i) { + my $o = $objects->[$i]; + next if $uuid ne $o->uuid; + $o->_set_group(undef); + return splice @$objects, $i, 1; + } } +############################################################################## + +=method add_object + + $new_entry = $group->add_object($new_entry); + $new_group = $group->add_object($new_group); + +Add an object (either a L or a L) to a group. This is the generic +equivalent of the object forms of L and L. + +=cut + sub add_object { my $self = shift; my $obj = shift; @@ -149,6 +216,16 @@ sub add_object { } } +=method remove_object + + $group->remove_object($entry); + $group->remove_object($group); + +Remove an object (either a L or a L) from a group. This is the generic +equivalent of the object forms of L and L. + +=cut + sub remove_object { my $self = shift; my $object = shift; @@ -158,42 +235,76 @@ sub remove_object { return $self->remove_group($object, @_) || $self->remove_entry($object, @_); } -sub remove_group { - my $self = shift; - my $uuid = is_ref($_[0]) ? $self->_group(shift)->uuid : shift; - my $objects = $self->{groups}; - for (my $i = 0; $i < @$objects; ++$i) { - my $o = $objects->[$i]; - next if $uuid ne $o->uuid; - return splice @$objects, $i, 1; - } -} +############################################################################## -sub remove_entry { +=method is_root + + $bool = $group->is_root; + +Determine if a group is the root group of its associated database. + +=cut + +sub is_root { my $self = shift; - my $uuid = is_ref($_[0]) ? $self->_entry(shift)->uuid : shift; - my $objects = $self->{entries}; - for (my $i = 0; $i < @$objects; ++$i) { - my $o = $objects->[$i]; - next if $uuid ne $o->uuid; - return splice @$objects, $i, 1; - } + my $kdbx = eval { $self->kdbx } or return; + return refaddr($kdbx->root) == refaddr($self); } +=method path + + $string = $group->path; + +Get a string representation of a group's lineage. This is used as the substitution value for the +C<{GROUP_PATH}> placeholder. See L. + +For a root group, the path is simply the name of the group. For deeper groups, the path is a period-separated +sequence of group names between the root group and C<$group>, including C<$group> but I the root group. +In other words, paths of deeper groups leave the root group name out. + + Database + -> Root # path is "Root" + -> Foo # path is "Foo" + -> Bar # path is "Foo.Bar" + +Yeah, it doesn't make much sense to me, either, but this matches the behavior of KeePass. + +=cut + sub path { my $self = shift; - my $lineage = $self->kdbx->trace_lineage($self) or return; - return join('.', map { $_->name } @$lineage); + return $self->name if $self->is_root; + my $lineage = $self->lineage or return; + my @parts = (@$lineage, $self); + shift @parts; + return join('.', map { $_->name } @parts); } +=method size + + $size = $group->size; + +Get the size (in bytes) of a group, including the size of all subroups and entries, if any. + +=cut + sub size { my $self = shift; return sum0 map { $_->size } @{$self->groups}, @{$self->entries}; } -sub level { $_[0]->kdbx->group_level($_[0]) } +=method depth -sub TO_JSON { +{%{$_[0]}} } + $depth = $group->depth; + +Get the depth of a group within a database. The root group is at depth 0, its direct children are at depth 1, +etc. A group not in a database tree structure returns a depth of -1. + +=cut + +sub depth { $_[0]->is_root ? 0 : (scalar @{$_[0]->lineage || []} || -1) } + +sub label { shift->name(@_) } 1; __END__ diff --git a/lib/File/KDBX/KDF.pm b/lib/File/KDBX/KDF.pm index c447cc0..7d29ec3 100644 --- a/lib/File/KDBX/KDF.pm +++ b/lib/File/KDBX/KDF.pm @@ -39,6 +39,14 @@ sub new { return $self->init(%args, %registration_args); } +=method init + + $kdf = $kdf->init(%attributes); + +Called by method to set attributes. You normally shouldn't call this. + +=cut + sub init { my $self = shift; my %args = @_; diff --git a/lib/File/KDBX/KDF/AES.pm b/lib/File/KDBX/KDF/AES.pm index 8ee1340..fd954f8 100644 --- a/lib/File/KDBX/KDF/AES.pm +++ b/lib/File/KDBX/KDF/AES.pm @@ -23,7 +23,7 @@ BEGIN { my $use_fork = 1; $use_fork = 0 if $ENV{NO_FORK} || !can_fork; - *USE_FORK = $use_fork ? sub() { 1 } : sub() { 0 }; + *_USE_FORK = $use_fork ? sub() { 1 } : sub() { 0 }; } sub init { @@ -58,7 +58,7 @@ sub _transform { my ($key_l, $key_r) = unpack('(a16)2', $key); - goto NO_FORK if !USE_FORK || $rounds < $FORK_OPTIMIZATION_THRESHOLD; + goto NO_FORK if !_USE_FORK || $rounds < $FORK_OPTIMIZATION_THRESHOLD; { my $pid = open(my $read, '-|') // do { alert "fork failed: $!"; goto NO_FORK }; if ($pid == 0) { # child @@ -73,7 +73,8 @@ sub _transform { return digest_data('SHA256', $l, $r); } - # FIXME: This used to work but now it crashes frequently. threads are discouraged anyway + # FIXME: This used to work but now it crashes frequently. Threads are now discouraged anyway, but it might + # be nice if this was available for no-fork platforms. # if ($ENV{THREADS} && eval 'use threads; 1') { # my $l = threads->create(\&_transform_half, $key_l, $seed, $rounds); # my $r = _transform_half($key_r, $seed, $rounds); diff --git a/lib/File/KDBX/Key.pm b/lib/File/KDBX/Key.pm index e7ac888..8fdb0ff 100644 --- a/lib/File/KDBX/Key.pm +++ b/lib/File/KDBX/Key.pm @@ -128,7 +128,7 @@ Get the raw encryption key. This is calculated based on the primitive(s). The C< challenge-response type keys and is ignored by other types. B The raw key is sensitive information and so is memory-protected while not being accessed. If you -access it, you should L it when you're done. +access it, you should memzero or L it when you're done. =cut @@ -156,7 +156,8 @@ sub _clear_raw_key { $key = $key->hide; -Encrypt the raw key for L. Returns itself to allow method chaining. +Put the raw key in L. Does nothing if the raw key is already in memory +protection. Returns itself to allow method chaining. =cut @@ -170,9 +171,8 @@ sub hide { $key = $key->show; -Decrypt the raw key so it can be accessed. Returns itself to allow method chaining. - -You normally don't need to call this because L calls this implicitly. +Bring the raw key out of memory protection. Does nothing if the raw key is already out of memory protection. +Returns itself to allow method chaining. =cut @@ -183,14 +183,15 @@ sub show { return $self; } -sub is_hidden { !!$SAFE{refaddr($_[0])} } +=method is_hidden + + $bool = $key->is_hidden; + +Get whether or not the key's raw secret is currently in memory protection. -# sub show_scoped { -# my $self = shift; -# require Scope::Guard; -# $self- -# return -# } +=cut + +sub is_hidden { !!$SAFE{refaddr($_[0])} } sub _safe { $SAFE{refaddr($_[0])} } sub _new_safe { $SAFE{refaddr($_[0])} = File::KDBX::Safe->new } diff --git a/lib/File/KDBX/Key/ChallengeResponse.pm b/lib/File/KDBX/Key/ChallengeResponse.pm index b17a35c..f9b2d48 100644 --- a/lib/File/KDBX/Key/ChallengeResponse.pm +++ b/lib/File/KDBX/Key/ChallengeResponse.pm @@ -20,6 +20,18 @@ sub init { return $self->hide; } +=method raw_key + + $raw_key = $key->raw_key; + $raw_key = $key->raw_key($challenge); + +Get the raw key which is the response to a challenge. The response will be saved so that subsequent calls +(with or without the challenge) can provide the response without challenging the responder again. Only once +response is saved at a time; if you call this with a different challenge, the new response is saved over any +previous response. + +=cut + sub raw_key { my $self = shift; if (@_) { @@ -36,7 +48,7 @@ sub raw_key { $response = $key->challenge($challenge, @options); -Issue a challenge and get a response, or throw if the responder failed. +Issue a challenge and get a response, or throw if the responder failed to provide one. =cut @@ -52,10 +64,25 @@ __END__ =head1 SYNOPSIS - my $key = File::KDBX::Key::ChallengeResponse->( - responder => sub { my $challenge = shift; ...; return $response }, - ); + use File::KDBX::Key::ChallengeResponse; + + my $responder = sub { + my $challenge = shift; + ...; # generate a response based on a secret of some sort + return $response; + }; + my $key = File::KDBX::Key::ChallengeResponse->new($responder); =head1 DESCRIPTION +A challenge-response key is kind of like multifactor authentication, except you don't really I +to a KDBX database because it's not a service. Specifically it would be the "what you have" component. It +assumes there is some device that can store a key that is only known to the unlocker of a database. +A challenge is made to the device and the response generated based on the key is used as the raw key. + +Inherets methods and attributes from L. + +This is a generic implementation where a responder subroutine is provided to provide the response. There is +also L which is a subclass that allows YubiKeys to be responder devices. + =cut diff --git a/lib/File/KDBX/Key/Composite.pm b/lib/File/KDBX/Key/Composite.pm index cd97314..86b803a 100644 --- a/lib/File/KDBX/Key/Composite.pm +++ b/lib/File/KDBX/Key/Composite.pm @@ -29,6 +29,15 @@ sub init { return $self->hide; } +=method raw_key + + $raw_key = $key->raw_key; + $raw_key = $key->raw_key($challenge); + +Get the raw key from each component key and return a generated composite raw key. + +=cut + sub raw_key { my $self = shift; my $challenge = shift; @@ -46,6 +55,42 @@ sub raw_key { ); } +=attr keys + + \@keys = $key->keys; + +Get one or more component L. + +=cut + +sub keys { + my $self = shift; + $self->{keys} = shift if @_; + return $self->{keys} ||= []; +} + +=method challenge + + $response = $key->challenge(...); + +Issues a challenge to any L components keys. Arguments are passed through +to each component key. The responses are hashed together and the composite response is returned. + +Returns empty string if there are no challenge-response components keys. + +=cut + +sub challenge { + my $self = shift; + + my @chalresp_keys = grep { $_->can('challenge') } @{$self->keys} or return ''; + + my @responses = map { $_->challenge(@_) } @chalresp_keys; + my $cleanup = erase_scoped \@responses; + + return digest_data('SHA256', @responses); +} + sub hide { my $self = shift; $_->hide for @{$self->keys}; @@ -58,30 +103,20 @@ sub show { return $self; } -sub challenge { - my $self = shift; - my @args = @_; +1; +__END__ - my @chalresp_keys = grep { $_->can('challenge') } @{$self->keys} or return ''; +=head1 SYNOPSIS - my @responses = map { $_->challenge(@args) } @chalresp_keys; - my $cleanup = erase_scoped \@responses; + use File::KDBX::Key::Composite; - return digest_data('SHA256', @responses); -} + my $key = File::KDBX::Key::Composite->(\@component_keys); -=attr keys +=head1 DESCRIPTION - \@keys = $key->keys; +A composite key is a collection of other keys. A master key capable of unlocking a KDBX database is always +a composite key, even if it only has a single component. -Get one or more component L. +Inherets methods and attributes from L. =cut - -sub keys { - my $self = shift; - $self->{keys} = shift if @_; - return $self->{keys} ||= []; -} - -1; diff --git a/lib/File/KDBX/Key/File.pm b/lib/File/KDBX/Key/File.pm index be9abd2..5c7cb12 100644 --- a/lib/File/KDBX/Key/File.pm +++ b/lib/File/KDBX/Key/File.pm @@ -5,7 +5,8 @@ use warnings; use strict; use Crypt::Digest qw(digest_data); -use Crypt::Misc 0.029 qw(decode_b64); +use Crypt::Misc 0.029 qw(decode_b64 encode_b64); +use Crypt::PRNG qw(random_bytes); use File::KDBX::Constants qw(:key_file); use File::KDBX::Error; use File::KDBX::Util qw(:erase trim); @@ -18,7 +19,20 @@ use parent 'File::KDBX::Key'; our $VERSION = '999.999'; # VERSION -sub init { +=method load + + $key = $key->load($filepath); + $key = $key->load(\$string); + $key = $key->load($fh); + $key = $key->load(*IO); + +Load a key file. + +=cut + +sub init { shift->load(@_) } + +sub load { my $self = shift; my $primitive = shift // throw 'Missing key primitive'; @@ -119,6 +133,57 @@ Get the filepath to the key file, if known. sub filepath { $_[0]->{filepath} } +=method save + + $key->save; + $key->save(%options); + +Write a key file. Available options: + +=for :list +* C - Type of key file (default: value of L, or C) +* C - Version of key file (default: value of L, or 2) +* C - Where to save the file (default: value of L) +* C - IO handle to write to (overrides C, one of which must be defined) +* C - Raw key (default: value of L) + +=cut + +sub save { + my $self = shift; + my %args = @_; + + my @cleanup; + my $raw_key = $args{raw_key} // $self->raw_key // random_bytes(32); + push @cleanup, erase_scoped $raw_key; + length($raw_key) == 32 or throw 'Raw key must be exactly 256 bits (32 bytes)', length => length($raw_key); + + my $type = $args{type} // $self->type // KEY_FILE_TYPE_XML; + my $version = $args{version} // $self->version // 2; + my $filepath = $args{filepath} // $self->filepath; + my $fh = $args{fh}; + + if (!openhandle($fh)) { + $filepath or throw 'Must specify where to safe the key file to'; + open($fh, '>:raw', $filepath) or throw "Failed to open key file for writing: $!"; + } + + if ($type == KEY_FILE_TYPE_XML) { + $self->_save_xml($fh, $raw_key, $version); + } + elsif ($type == KEY_FILE_TYPE_BINARY) { + print $fh $raw_key; + } + elsif ($type == KEY_FILE_TYPE_HEX) { + my $hex = uc(unpack('H*', $raw_key)); + push @cleanup, erase_scoped $hex; + print $fh $hex; + } + else { + throw "Cannot save $type key file (invalid type)", type => $type; + } +} + ############################################################################## sub _load_xml { @@ -166,7 +231,7 @@ sub _load_xml { $$out = pack('H*', $data); $hash = pack('H*', $hash); my $got_hash = digest_data('SHA256', $$out); - $hash eq substr($got_hash, 0, 4) + $hash eq substr($got_hash, 0, length($hash)) or throw 'Checksum mismatch', got => $got_hash, expected => $hash; return (KEY_FILE_TYPE_XML, $version); } @@ -174,4 +239,83 @@ sub _load_xml { throw 'Unexpected data in key file', version => $version, data => $data; } +sub _save_xml { + my $self = shift; + my $fh = shift; + my $raw_key = shift; + my $version = shift // 2; + + my @cleanup; + + my $dom = XML::LibXML::Document->new('1.0', 'UTF-8'); + my $doc = XML::LibXML::Element->new('KeyFile'); + $dom->setDocumentElement($doc); + my $meta_node = XML::LibXML::Element->new('Meta'); + $doc->appendChild($meta_node); + my $version_node = XML::LibXML::Element->new('Version'); + $version_node->appendText(sprintf('%.1f', $version)); + $meta_node->appendChild($version_node); + my $key_node = XML::LibXML::Element->new('Key'); + $doc->appendChild($key_node); + my $data_node = XML::LibXML::Element->new('Data'); + $key_node->appendChild($data_node); + + if (int($version) == 1) { + my $b64 = encode_b64($raw_key); + push @cleanup, erase_scoped $b64; + $data_node->appendText($b64); + } + elsif (int($version) == 2) { + my @hex = unpack('(H8)8', $raw_key); + my $hex = uc(sprintf("\n %s\n %s\n ", join(' ', @hex[0..3]), join(' ', @hex[4..7]))); + push @cleanup, erase_scoped $hex, @hex; + $data_node->appendText($hex); + my $hash = digest_data('SHA256', $raw_key); + substr($hash, 4) = ''; + $hash = uc(unpack('H*', $hash)); + $data_node->setAttribute('Hash', $hash); + } + else { + throw 'Failed to save unsupported key file version', version => $version; + } + + $dom->toFH($fh, 1); +} + 1; +__END__ + +=head1 SYNOPSIS + + use File::KDBX::Constants qw(:key_file); + use File::KDBX::Key::File; + + ### Create a key file: + + my $key = File::KDBX::Key::File->new( + filepath => 'path/to/file.keyx', + type => KEY_FILE_TYPE_XML, # optional + version => 2, # optional + raw_key => $raw_key, # optional - leave undefined to generate a random key + ); + $key->save; + + ### Use a key file: + + my $key2 = File::KDBX::Key::File->new('path/to/file.keyx'); + # OR + my $key2 = File::KDBX::Key::File->new(\$secret); + # OR + my $key2 = File::KDBX::Key::File->new($fh); # or *IO + +=head1 DESCRIPTION + +A file key (or "key file") is the type of key where the secret is a file. The secret is either the file +contents or is generated based on the file contents. In order to lock and unlock a KDBX database with a key +file, the same file must be presented. The database cannot be opened without the file. + +Inherets methods and attributes from L. + +There are multiple types of key files supported. See L. This module can read and write key files. + +=cut diff --git a/lib/File/KDBX/Key/Password.pm b/lib/File/KDBX/Key/Password.pm index 84f8e38..ba46f99 100644 --- a/lib/File/KDBX/Key/Password.pm +++ b/lib/File/KDBX/Key/Password.pm @@ -24,3 +24,18 @@ sub init { } 1; +__END__ + +=head1 SYNOPSIS + + use File::KDBX::Key::Password; + + my $key = File::KDBX::Key::Password->new($password); + +=head1 DESCRIPTION + +A password key is as simple as it sounds. It's just a password or passphrase. + +Inherets methods and attributes from L. + +=cut diff --git a/lib/File/KDBX/Key/YubiKey.pm b/lib/File/KDBX/Key/YubiKey.pm index 7b7132c..fb22bf8 100644 --- a/lib/File/KDBX/Key/YubiKey.pm +++ b/lib/File/KDBX/Key/YubiKey.pm @@ -430,6 +430,8 @@ A L is a type of challenge-response key. This module f challenge-response implementation, so this might not work at all with incompatible challenge-response implementations (e.g. KeeChallenge). +Inherets methods and attributes from L. + To use this type of key to secure a L database, you also need to install the L and configure at least one of the slots on your YubiKey for HMAC-SHA1 challenge response mode. You can use the YubiKey @@ -441,9 +443,9 @@ See L for more information. =for :list * C - Path to the L program -* C - Extra arguments to the B program * C - Path to the L program -* C - Extra arguments to the B program +* C - Extra arguments to the B program +* C - Extra arguments to the B program B searches for these programs in the same way perl typically searches for executables (using the C environment variable on many platforms). If the programs aren't installed normally, or if you want to @@ -456,4 +458,7 @@ C from L worked in Windows, but it probably doesn't. I spe various quirks to L and L implementations but never quite got it to worked reliably without deadlocks. Maybe I'll revisit this later. Hit me up so I know if there's demand. +It would also be possible to implement this is an XS module that incorporated ykcore, using libusb-1 which +would probably make it more portable with Windows. Perhaps if I get around to it. + =cut diff --git a/lib/File/KDBX/Object.pm b/lib/File/KDBX/Object.pm index 09c790f..e1c8c8e 100644 --- a/lib/File/KDBX/Object.pm +++ b/lib/File/KDBX/Object.pm @@ -14,13 +14,14 @@ use namespace::clean; our $VERSION = '999.999'; # VERSION my %KDBX; +my %PARENT; =method new - $object = File::KDBX::Entry->new; - $object = File::KDBX::Entry->new(%attributes); - $object = File::KDBX::Entry->new($data); - $object = File::KDBX::Entry->new($data, $kdbx); + $object = File::KDBX::Object->new; + $object = File::KDBX::Object->new(%attributes); + $object = File::KDBX::Object->new(\%data); + $object = File::KDBX::Object->new(\%data, $kdbx); Construct a new KDBX object. @@ -32,11 +33,11 @@ and: File::KDBX::Entry->new({username => 'iambatman'}); # WRONG -In the first, an empty entry is first created and then initialized with whatever I are given. In -the second, a hashref is blessed and essentially becomes the entry. The significance is that the hashref -key-value pairs will remain as-is so the structure is expected to adhere to the shape of a raw B, -whereas with the first the attributes will set the structure in the correct way (just like using the entry -object accessors / getters / setters). +In the first, an empty object is first created and then initialized with whatever I are given. In +the second, a hashref is blessed and essentially becomes the object. The significance is that the hashref +key-value pairs will remain as-is so the structure is expected to adhere to the shape of a raw B +(which varies based on the type of object), whereas with the first the attributes will set the structure in +the correct way (just like using the object accessors / getters / setters). The second example isn't I wrong -- this type of construction is supported for a reason, to allow for working with KDBX objects at a low level -- but it is wrong in this specific case only because @@ -75,6 +76,16 @@ sub new { return $self; } +sub _set_default_attributes { die 'Not implemented' } + +=method init + + $object = $object->init(%attributes); + +Called by the constructor to set attributes. You normally should not call this. + +=cut + sub init { my $self = shift; my %args = @_; @@ -92,6 +103,7 @@ sub DESTROY { return if in_global_destruction; my $self = shift; delete $KDBX{refaddr($self)}; + delete $PARENT{refaddr($self)}; } =method wrap @@ -103,8 +115,8 @@ Ensure that a KDBX object is blessed. =cut sub wrap { - my $class = shift; - my $object = shift; + my $class = shift; + my $object = shift; return $object if blessed $object && $object->isa($class); return $class->new(@_, @$object) if is_arrayref($object); return $class->new($object, @_); @@ -116,33 +128,32 @@ sub wrap { $object->label($label); Get or set the object's label, a text string that can act as a non-unique identifier. For an entry, the label -is its title. For a group, the label is its name. +is its title string. For a group, the label is its name. =cut -sub label { die "Not implemented" } +sub label { die 'Not implemented' } =method clone $object_copy = $object->clone; $object_copy = File::KDBX::Object->new($object); -Make a clone of an entry. By default the clone is indeed an exact copy that is associated with the same -database but not actually included in the object tree (i.e. it has no parent), but some options are allowed to +Make a clone of an object. By default the clone is indeed an exact copy that is associated with the same +database but not actually included in the object tree (i.e. it has no parent). Some options are allowed to get different effects: =for :list -* C - Set a new UUID; value can be the new UUID, truthy to generate a random UUID, or falsy to keep - the original UUID (default: same value as C) -* C - If set, add the copy to the same parent (default: false) -* C - If set, change the name or title of the copy to "C<$original_title> - Copy". -* C - Toggle whether or not to copy child entries, if any (default: true) -* C - Toggle whether or not to copy child groups, if any (default: true) -* C - Toggle whether or not to copy the entry history, if any (default: true) -* C - Toggle whether or not cloned entry's Password string should be set to a reference to - their original entry's Password string. -* C - Toggle whether or not cloned entry's UserName string should be set to a reference to - their original entry's UserName string. +* C - If set, generate a new UUID for the copy (default: false) +* C - If set, add the copy to the same parent group, if any (default: false) +* C - If set, append " - Copy" to the object's title or name (default: false) +* C - If set, copy child entries, if any (default: true) +* C - If set, copy child groups, if any (default: true) +* C - If set, copy entry history, if any (default: true) +* C - Toggle whether or not cloned entry's Password string should be set as a field + reference to the original entry's Password string (default: false) +* C - Toggle whether or not cloned entry's UserName string should be set as a field + reference to the original entry's UserName string (default: false) =cut @@ -194,8 +205,8 @@ sub STORABLE_thaw { my $kdbx = $KDBX{$addr}; $self->kdbx($kdbx) if $kdbx; - if ($self->{uuid}) { - if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->isa('File::KDBX::Entry')) { + if (defined $self->{uuid}) { + if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->can('strings')) { my $uuid = format_uuid($self->{uuid}); my $clone_obj = do { local $CLONE{new_uuid} = 0; @@ -204,7 +215,7 @@ sub STORABLE_thaw { local $CLONE{history} = 1; local $CLONE{reference_password} = 0; local $CLONE{reference_username} = 0; - bless Storable::dclone({%$clone}), 'File::KDBX::Entry'; + bless Storable::dclone({%$clone}), 'File::KDBX::Entry'; }; my $txn = $self->begin_work($clone_obj); if ($CLONE{reference_password}) { @@ -262,22 +273,79 @@ sub id { format_uuid(shift->uuid, @_) } =method group +=method parent + $group = $object->group; + # OR equivalently + $group = $object->parent; Get the parent group to which an object belongs or C if it belongs to no group. -Alias: C - =cut sub group { my $self = shift; - my $lineage = $self->kdbx->trace_lineage($self) or return; - return pop @$lineage; + my $addr = refaddr($self); + if (my $group = $PARENT{$addr}) { + my $method = $self->_parent_container; + for my $object (@{$group->$method}) { + return $group if $addr == refaddr($object); + } + delete $PARENT{$addr}; + } + # always get lineage from root to leaf because the other way requires parent, so it would be recursive + my $lineage = $self->kdbx->_trace_lineage($self) or return; + my $group = pop @$lineage or return; + $PARENT{$addr} = $group; weaken $PARENT{$addr}; + return $group; } sub parent { shift->group(@_) } +sub _set_group { + my $self = shift; + if (my $parent = shift) { + $PARENT{refaddr($self)} = $parent; + } + else { + delete $PARENT{refaddr($self)}; + } + return $self; +} + +### Name of the parent attribute expected to contain the object +sub _parent_container { die 'Not implemented' } + +=method lineage + + \@lineage = $object->lineage; + \@lineage = $object->lineage($base_group); + +Get the direct line of ancestors from C<$base_group> (default: the root group) to an object. The lineage +includes the base group but I the target object. Returns C if the target is not in the database +structure. Returns an empty arrayref is the object itself is a root group. + +=cut + +sub lineage { + my $self = shift; + my $base = shift; + + my $base_addr = $base ? refaddr($base) : 0; + + # try leaf to root + my @path; + my $o = $self; + while ($o = $o->parent) { + unshift @path, $o; + last if $base_addr == refaddr($o); + } + return \@path if @path && ($base_addr == refaddr($path[0]) || $path[0]->is_root); + + # try root to leaf + return $self->kdbx->_trace_lineage($self, $base); +} + =method remove $object = $object->remove; @@ -401,9 +469,27 @@ sub custom_data_value { return $data->{value}; } +sub _wrap_group { + my $self = shift; + my $group = shift; + require File::KDBX::Group; + return File::KDBX::Group->wrap($group, $KDBX{refaddr($self)}); +} + +sub _wrap_entry { + my $self = shift; + my $entry = shift; + require File::KDBX::Entry; + return File::KDBX::Entry->wrap($entry, $KDBX{refaddr($self)}); +} + +sub TO_JSON { +{%{$_[0]}} } + 1; __END__ +=for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON + =head1 DESCRIPTION KDBX is an object database. This abstract class represents an object. You should not use this class directly diff --git a/lib/File/KDBX/Safe.pm b/lib/File/KDBX/Safe.pm index 24a3cf4..0e445c6 100644 --- a/lib/File/KDBX/Safe.pm +++ b/lib/File/KDBX/Safe.pm @@ -52,9 +52,9 @@ sub DESTROY { !in_global_destruction and $_[0]->unlock } =method clear - $safe->clear; + $safe = $safe->clear; -Clear a safe, removing all store contents permanently. +Clear a safe, removing all store contents permanently. Returns itself to allow method chaining. =cut @@ -66,14 +66,14 @@ sub clear { return $self; } +=method lock + =method add $safe = $safe->lock(@strings); $safe = $safe->lock(\@strings); -Add strings to be encrypted. - -Alias: C +Add one or more strings to the memory protection stream. Returns itself to allow method chaining. =cut @@ -126,19 +126,23 @@ sub add { return $self; } +=method lock_protected + =method add_protected - $safe = $safe->add_protected(@strings); - $safe = $safe->add_protected(\@strings); + $safe = $safe->lock_protected(@strings); + $safe = $safe->lock_protected(\@strings); -Add strings that are already encrypted. +Add strings that are already encrypted. Returns itself to allow method chaining. -B You must add already-encrypted strings in the order in which they were original encrypted or they -will not decrypt correctly. You almost certainly do not want to add both unprotected and protected strings to -a safe. +B The cipher must be the same as was used to originally encrypt the strings. You must add +already-encrypted strings in the order in which they were original encrypted or they will not decrypt +correctly. You almost certainly do not want to add both unprotected and protected strings to a safe. =cut +sub lock_protected { shift->add_protected(@_) } + sub add_protected { my $self = shift; my $filter = is_coderef($_[0]) ? shift : undef; @@ -174,7 +178,9 @@ sub add_protected { $safe = $safe->unlock; -Decrypt all the strings. Each stored string is set to its original value. +Decrypt all the strings. Each stored string is set to its original value, potentially overwriting any value +that might have been set after locking the string (so you probably should avoid modification to strings while +locked). The safe is implicitly cleared. Returns itself to allow method chaining. This happens automatically when the safe is garbage-collected. @@ -231,6 +237,8 @@ sub unlock { Peek into the safe at a particular string without decrypting the whole safe. A copy of the string is returned, and in order to ensure integrity of the memory protection you should erase the copy when you're done. +Returns C if the given C<$string> is not in memory protection. + =cut sub peek { diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm index 2d83074..4b4c2c7 100644 --- a/lib/File/KDBX/Util.pm +++ b/lib/File/KDBX/Util.pm @@ -119,13 +119,11 @@ sub can_fork { return 1; } -=func clone_nomagic +=func clone - $clone = clone_nomagic($thing); + $clone = clone($thing); -Clone deeply without keeping [most of] the magic. - -B At the moment the implementation is naïve and won't respond well to nontrivial data. +Clone deeply. This is an unadorned alias to L C. =cut @@ -134,6 +132,17 @@ sub clone { goto &Storable::dclone; } +=func clone_nomagic + + $clone = clone_nomagic($thing); + +Clone deeply without keeping [most of] the magic. + +B At the moment the implementation is naïve and won't respond well to nontrivial data or recursive +structures. + +=cut + sub clone_nomagic { my $thing = shift; if (is_arrayref($thing)) { @@ -153,7 +162,8 @@ sub clone_nomagic { =func dumper - $str = dumper $struct; + $str = dumper $thing; + dumper $thing; # in void context, prints to STDERR Like L but slightly terser in some cases relevent to L. @@ -241,7 +251,7 @@ sub erase { for (@_) { if (!is_ref($_)) { next if !defined $_ || readonly $_; - if (USE_COWREFCNT()) { + if (_USE_COWREFCNT()) { my $cowrefcnt = B::COW::cowrefcnt($_); goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt; } @@ -258,7 +268,7 @@ sub erase { } elsif (is_scalarref($_)) { next if !defined $$_ || readonly $$_; - if (USE_COWREFCNT()) { + if (_USE_COWREFCNT()) { my $cowrefcnt = B::COW::cowrefcnt($$_); goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt; } @@ -391,7 +401,7 @@ sub gunzip { return $out; } -=func gunzip +=func gzip $zipped = gzip($string); @@ -762,6 +772,14 @@ sub uri_escape_utf8 { return $_; } +=func uri_unescape_utf8 + + $string = uri_unescape_utf8($string); + +Inverse of L. + +=cut + sub uri_unescape_utf8 { local $_ = shift // return; s/\%([A-Fa-f0-9]{2})/chr(hex($1))/; @@ -789,7 +807,7 @@ sub uuid { BEGIN { my $use_cowrefcnt = eval { require B::COW; 1 }; - *USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 }; + *_USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 }; } ### -------------------------------------------------------------------------- diff --git a/t/crypt.t b/t/crypt.t index 576f708..7e54ce9 100644 --- a/t/crypt.t +++ b/t/crypt.t @@ -7,13 +7,12 @@ use lib 't/lib'; use TestCommon; use Crypt::Misc 0.029 qw(decode_b64 encode_b64); +use File::KDBX::Cipher; use File::KDBX::Constants qw(CIPHER_UUID_AES256); use IO::Handle; +use PerlIO::via::File::KDBX::Crypt; use Test::More; -BEGIN { use_ok 'File::KDBX::Cipher' } -BEGIN { use_ok 'PerlIO::via::File::KDBX::Crypt' } - subtest 'Round-trip block stream' => sub { plan tests => 3; my $block_cipher = File::KDBX::Cipher->new(uuid => CIPHER_UUID_AES256, key => 0x01 x 32, iv => 0x01 x 16); diff --git a/t/database.t b/t/database.t index 951ff74..86c6f4d 100644 --- a/t/database.t +++ b/t/database.t @@ -8,28 +8,50 @@ use FindBin qw($Bin); use lib "$Bin/lib"; use TestCommon; +use File::KDBX; +use Test::Deep; use Test::More; -BEGIN { use_ok 'File::KDBX' } - subtest 'Create a new database' => sub { my $kdbx = File::KDBX->new; $kdbx->add_group(name => 'Meh'); - ok $kdbx->_is_implicit_root, 'Database starts off with implicit root'; + ok $kdbx->_has_implicit_root, 'Database starts off with implicit root'; - $kdbx->add_entry({ + my $entry = $kdbx->add_entry({ username => 'hello', password => {value => 'This is a secret!!!!!', protect => 1}, }); - ok !$kdbx->_is_implicit_root, 'Adding an entry to the root group makes it explicit'; - - $kdbx->unlock; + ok !$kdbx->_has_implicit_root, 'Adding an entry to the root group makes it explicit'; - # dumper $kdbx->groups; + $entry->remove; + ok $kdbx->_has_implicit_root, 'Removing group makes the root group implicit again'; +}; - pass; +subtest 'Clone' => sub { + my $kdbx = File::KDBX->new; + $kdbx->add_group(name => 'Passwords')->add_entry(title => 'My Entry'); + + my $copy = $kdbx->clone; + cmp_deeply $copy, $kdbx, 'Clone keeps the same structure and data' or dumper $copy; + + isnt $kdbx, $copy, 'Clone is a different object'; + isnt $kdbx->root, $copy->root, + 'Clone root group is a different object'; + isnt $kdbx->root->groups->[0], $copy->root->groups->[0], + 'Clone group is a different object'; + isnt $kdbx->root->groups->[0]->entries->[0], $copy->root->groups->[0]->entries->[0], + 'Clone entry is a different object'; + + my @objects = (@{$copy->all_groups}, @{$copy->all_entries}); + subtest 'Cloned objects refer to the cloned database' => sub { + plan tests => scalar @_; + for my $object (@objects) { + my $object_kdbx = eval { $object->kdbx }; + is $object_kdbx, $copy, 'Object: ' . $object->label; + } + }, @objects; }; done_testing; diff --git a/t/entry.t b/t/entry.t index a4286cf..9171eb4 100644 --- a/t/entry.t +++ b/t/entry.t @@ -6,12 +6,11 @@ use strict; use lib 't/lib'; use TestCommon; +use File::KDBX::Entry; use File::KDBX; use Test::Deep; use Test::More; -BEGIN { use_ok 'File::KDBX::Entry' } - subtest 'Construction' => sub { my $entry = File::KDBX::Entry->new(my $data = {username => 'foo'}); is $entry, $data, 'Provided data structure becomes the object'; @@ -37,6 +36,7 @@ subtest 'Construction' => sub { custom_data => {}, custom_icon_uuid => undef, foreground_color => "", + history => [], icon_id => "Password", override_url => "", previous_parent_group => undef, diff --git a/t/error.t b/t/error.t index ae467f2..2caab01 100644 --- a/t/error.t +++ b/t/error.t @@ -6,11 +6,10 @@ use strict; use lib 't/lib'; use TestCommon; +use File::KDBX::Error; use File::KDBX; use Test::More; -BEGIN { use_ok 'File::KDBX::Error' } - subtest 'Errors' => sub { my $error = exception { local $! = 1; diff --git a/t/group.t b/t/group.t new file mode 100755 index 0000000..af0998b --- /dev/null +++ b/t/group.t @@ -0,0 +1,22 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Group; +use File::KDBX; +use Test::More; + +subtest 'Path' => sub { + my $kdbx = File::KDBX->new; + my $group_a = $kdbx->add_group(name => 'Group A'); + my $group_b = $group_a->add_group(name => 'Group B'); + is $kdbx->root->path, 'Root', 'Root group has path'; + is $group_a->path, 'Group A', 'Layer 1 group has path'; + is $group_b->path, 'Group A.Group B', 'Layer 2 group has path'; +}; + +done_testing; diff --git a/t/hash-block.t b/t/hash-block.t index 006f617..461ad55 100644 --- a/t/hash-block.t +++ b/t/hash-block.t @@ -8,10 +8,9 @@ use TestCommon qw(:no_warnings_test); use File::KDBX::Util qw(can_fork); use IO::Handle; +use PerlIO::via::File::KDBX::HashBlock; use Test::More; -BEGIN { use_ok 'PerlIO::via::File::KDBX::HashBlock' } - { my $expected_plaintext = 'Tiny food from Spain!'; @@ -29,22 +28,6 @@ BEGIN { use_ok 'PerlIO::via::File::KDBX::HashBlock' } is $plaintext, $expected_plaintext, 'Hash-block just a little bit'; } -subtest 'Error handling' => sub { - pipe(my $read, my $write) or die "pipe failed: $!\n"; - - PerlIO::via::File::KDBX::HashBlock->push($read); - - print $write 'blah blah blah'; - close($write) or die "close failed: $!"; - - is $read->error, 0, 'Read handle starts out fine'; - my $data = do { local $/; <$read> }; - is $read->error, 1, 'Read handle can enter and error state'; - - like $PerlIO::via::File::KDBX::HashBlock::ERROR, qr/invalid block index/i, - 'Error object is available'; -}; - SKIP: { skip 'Tests require fork' if !can_fork; @@ -70,4 +53,20 @@ SKIP: { waitpid($pid, 0) or die "wait failed: $!\n"; } +subtest 'Error handling' => sub { + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + PerlIO::via::File::KDBX::HashBlock->push($read); + + print $write 'blah blah blah'; + close($write) or die "close failed: $!"; + + is $read->error, 0, 'Read handle starts out fine'; + my $data = do { local $/; <$read> }; + is $read->error, 1, 'Read handle can enter and error state'; + + like $PerlIO::via::File::KDBX::HashBlock::ERROR, qr/invalid block index/i, + 'Error object is available'; +}; + done_testing; diff --git a/t/hmac-block.t b/t/hmac-block.t index bff3d5e..75b467c 100644 --- a/t/hmac-block.t +++ b/t/hmac-block.t @@ -8,10 +8,9 @@ use TestCommon qw(:no_warnings_test); use File::KDBX::Util qw(can_fork); use IO::Handle; +use PerlIO::via::File::KDBX::HmacBlock; use Test::More; -BEGIN { use_ok 'PerlIO::via::File::KDBX::HmacBlock' } - my $KEY = "\x01" x 64; { @@ -31,22 +30,6 @@ my $KEY = "\x01" x 64; is $plaintext, $expected_plaintext, 'HMAC-block just a little bit'; } -subtest 'Error handling' => sub { - pipe(my $read, my $write) or die "pipe failed: $!\n"; - - PerlIO::via::File::KDBX::HmacBlock->push($read, key => $KEY); - - print $write 'blah blah blah'; - close($write) or die "close failed: $!"; - - is $read->error, 0, 'Read handle starts out fine'; - my $data = do { local $/; <$read> }; - is $read->error, 1, 'Read handle can enter and error state'; - - like $PerlIO::via::File::KDBX::HmacBlock::ERROR, qr/failed to read HMAC/i, - 'Error object is available'; -}; - SKIP: { skip 'Tests require fork' if !can_fork; @@ -72,4 +55,20 @@ SKIP: { waitpid($pid, 0) or die "wait failed: $!\n"; } +subtest 'Error handling' => sub { + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + PerlIO::via::File::KDBX::HmacBlock->push($read, key => $KEY); + + print $write 'blah blah blah'; + close($write) or die "close failed: $!"; + + is $read->error, 0, 'Read handle starts out fine'; + my $data = do { local $/; <$read> }; + is $read->error, 1, 'Read handle can enter and error state'; + + like $PerlIO::via::File::KDBX::HmacBlock::ERROR, qr/failed to read HMAC/i, + 'Error object is available'; +}; + done_testing; diff --git a/t/kdf-aes-pp.t b/t/kdf-aes-pp.t index fa111e0..e5f0fc6 100644 --- a/t/kdf-aes-pp.t +++ b/t/kdf-aes-pp.t @@ -6,14 +6,12 @@ use strict; use lib 't/lib'; use TestCommon; +BEGIN { $ENV{PERL_FILE_KDBX_XS} = 0 } +use File::KDBX::KDF; + use File::KDBX::Constants qw(:kdf); use Test::More; -BEGIN { - $ENV{PERL_FILE_KDBX_XS} = 0; - use_ok('File::KDBX::KDF'); -} - my $kdf = File::KDBX::KDF->new(uuid => KDF_UUID_AES, seed => "\1" x 32, rounds => 10); is File::KDBX::XS_LOADED(), 0, 'XS can be avoided'; diff --git a/t/kdf.t b/t/kdf.t index 372298d..99c37f4 100644 --- a/t/kdf.t +++ b/t/kdf.t @@ -7,10 +7,9 @@ use lib 't/lib'; use TestCommon; use File::KDBX::Constants qw(:kdf); +use File::KDBX::KDF; use Test::More; -BEGIN { use_ok('File::KDBX::KDF') } - subtest 'AES KDF' => sub { my $kdf1 = File::KDBX::KDF->new(uuid => KDF_UUID_AES, seed => "\1" x 32, rounds => 10); my $result1 = $kdf1->transform("\2" x 32); diff --git a/t/keys.t b/t/keys.t index 0d03e65..62d2a1a 100644 --- a/t/keys.t +++ b/t/keys.t @@ -7,10 +7,11 @@ use lib 't/lib'; use TestCommon; use Crypt::Misc 0.029 qw(decode_b64 encode_b64); +use File::KDBX::Constants qw(:key_file); +use File::KDBX::Key; +use File::Temp qw(tempfile); use Test::More; -BEGIN { use_ok 'File::KDBX::Key' } - subtest 'Primitives' => sub { my $pkey = File::KDBX::Key->new('password'); isa_ok $pkey, 'File::KDBX::Key::Password'; @@ -33,52 +34,90 @@ subtest 'Primitives' => sub { 'Can calculate raw key from composite' or diag encode_b64($ckey->raw_key); }; -subtest 'File keys' => sub { - my $key = File::KDBX::Key::File->new(testfile(qw{keys xmlv1.key})); - is $key->raw_key, decode_b64('OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI='), - 'Can calculate raw key from XML file' or diag encode_b64($key->raw_key); - is $key->type, 'xml', 'file type is detected as xml'; - is $key->version, '1.0', 'file version is detected as xml'; - - $key = File::KDBX::Key::File->new(testfile(qw{keys xmlv2.key})); - is $key->raw_key, decode_b64('OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI='), - 'Can calculate raw key from XML file' or diag encode_b64($key->raw_key); - is $key->type, 'xml', 'file type is detected as xml'; - is $key->version, '2.0', 'file version is detected as xml'; - - $key = File::KDBX::Key::File->new(testfile(qw{keys binary.key})); - is $key->raw_key, decode_b64('QlkDxuYbDPDpDXdK1470EwVBL+AJBH2gvPA9lxNkFEk='), - 'Can calculate raw key from binary file' or diag encode_b64($key->raw_key); - is $key->type, 'binary', 'file type is detected as binary'; - - $key = File::KDBX::Key::File->new(testfile(qw{keys hex.key})); - is $key->raw_key, decode_b64('QlkDxuYbDPDpDXdK1470EwVBL+AJBH2gvPA9lxNkFEk='), - 'Can calculate raw key from hex file' or diag encode_b64($key->raw_key); - is $key->type, 'hex', 'file type is detected as hex'; - - $key = File::KDBX::Key::File->new(testfile(qw{keys hashed.key})); - is $key->raw_key, decode_b64('8vAO4mrMeq6iCa1FHeWm/Mj5al8HIv2ajqsqsSeUC6U='), - 'Can calculate raw key from binary file' or diag encode_b64($key->raw_key); - is $key->type, 'hashed', 'file type is detected as hashed'; - +for my $test ( + [KEY_FILE_TYPE_XML, 'xmlv1.key', 'OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI=', '1.0'], + [KEY_FILE_TYPE_XML, 'xmlv2.key', 'OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI=', '2.0'], + [KEY_FILE_TYPE_BINARY, 'binary.key', 'QlkDxuYbDPDpDXdK1470EwVBL+AJBH2gvPA9lxNkFEk='], + [KEY_FILE_TYPE_HEX, 'hex.key', 'QlkDxuYbDPDpDXdK1470EwVBL+AJBH2gvPA9lxNkFEk='], + [KEY_FILE_TYPE_HASHED, 'hashed.key', '8vAO4mrMeq6iCa1FHeWm/Mj5al8HIv2ajqsqsSeUC6U='], +) { + my ($type) = @$test; + subtest "Load $type key file" => sub { + my ($type, $filename, $expected_key, $version) = @_; + + my $key = File::KDBX::Key::File->new(testfile('keys', $filename)); + is $key->raw_key, decode_b64($expected_key), + "Can calculate raw key from $type file" or diag encode_b64($key->raw_key); + is $key->type, $type, "File type is detected as $type"; + is $key->version, $version, "File version is detected as $version" if defined $version; + }, @$test; + + subtest "Save $type key file" => sub { + my ($type, $filename, $expected_key, $version) = @_; + + my ($fh, $filepath) = tempfile('keyfile-XXXXXX', TMPDIR => 1, UNLINK => 1, SUFFIX => '.key'); + note $filepath; + my $key = File::KDBX::Key::File->new( + filepath => $filepath, + type => $type, + version => $version, + raw_key => decode_b64($expected_key), + ); + + my $e = exception { $key->save }; + close($fh); + + if ($type == KEY_FILE_TYPE_HASHED) { + like $e, qr/invalid type/i, "Cannot save $type file"; + return; + } + is $e, undef, "Save $type file"; + + my $key2 = File::KDBX::Key::File->new($filepath); + is $key2->type, $key->type, 'Loaded key file has the same type'; + is $key2->raw_key, $key->raw_key, 'Loaded key file has the same raw key'; + }, @$test; +} + +subtest 'IO handle key files' => sub { my $buf = 'password'; open(my $fh, '<', \$buf) or die "open failed: $!\n"; - $key = File::KDBX::Key::File->new($fh); + my $key = File::KDBX::Key::File->new($fh); is $key->raw_key, decode_b64('XohImNooBHFR0OVvjcYpJ3NgPQ1qq73WKhHvch0VQtg='), 'Can calculate raw key from file handle' or diag encode_b64($key->raw_key); is $key->type, 'hashed', 'file type is detected as hashed'; - is exception { File::KDBX::Key::File->new }, undef, 'Can instantiate uninitialized'; + my ($fh_save, $filepath) = tempfile('keyfile-XXXXXX', TMPDIR => 1, UNLINK => 1, SUFFIX => '.key'); + ok $key->save(fh => $fh_save, type => KEY_FILE_TYPE_XML), 'Save key file using IO handle'; + close($fh_save); + + my $key2 = File::KDBX::Key::File->new($filepath); + is $key2->type, KEY_FILE_TYPE_XML, 'Loaded key file has the same type'; + is $key2->filepath, $filepath, 'Loaded key remembers the filepath'; + is $key2->raw_key, $key->raw_key, 'Loaded key file has the same raw key'; + $key2->reload; + is $key2->raw_key, $key->raw_key, 'Raw key is the same when reloaded same file'; + + my $easy_raw_key = "\1" x 32; + $key->init(\$easy_raw_key); + $key->save(filepath => $filepath); + + $key2->reload; + is $key2->raw_key, "\1" x 32, 'Raw key is changed after reload'; +}; + +subtest 'Key file error handling' => sub { + is exception { File::KDBX::Key::File->new }, undef, 'Cannot instantiate uninitialized'; like exception { File::KDBX::Key::File->init }, - qr/^Missing key primitive/, 'Throws if no primitive is provided'; + qr/^Missing key primitive/, 'Throw if no primitive is provided'; like exception { File::KDBX::Key::File->new(testfile(qw{keys nonexistent})) }, - qr/^Failed to open key file/, 'Throws if file is missing'; + qr/^Failed to open key file/, 'Throw if file is missing'; like exception { File::KDBX::Key::File->new({}) }, - qr/^Unexpected primitive type/, 'Throws if primitive is the wrong type'; + qr/^Unexpected primitive type/, 'Throw if primitive is the wrong type'; }; done_testing; diff --git a/t/safe.t b/t/safe.t index 79d8e4c..efcf31f 100644 --- a/t/safe.t +++ b/t/safe.t @@ -7,11 +7,10 @@ use strict; use lib 't/lib'; use TestCommon; +use File::KDBX::Safe; use Test::Deep; use Test::More; -BEGIN { use_ok 'File::KDBX::Safe' } - my $secret = 'secret'; my @strings = ( diff --git a/t/util.t b/t/util.t index 54ed365..5ea4359 100644 --- a/t/util.t +++ b/t/util.t @@ -6,10 +6,9 @@ use strict; use lib 't/lib'; use TestCommon; +use File::KDBX::Util qw(:all); use Test::More; -BEGIN { use_ok('File::KDBX::Util', qw{empty format_uuid generate_uuid nonempty pad_pkcs7 snakify uuid}) } - can_ok('File::KDBX::Util', qw{ assert_64bit can_fork