From: Charles McGarvey Date: Wed, 13 Apr 2022 21:14:48 +0000 (-0600) Subject: add initial WIP X-Git-Tag: v0.800~36 X-Git-Url: https://git.dogcows.com/gitweb?p=chaz%2Fp5-File-KDBX;a=commitdiff_plain;h=f63182fc62b25269b1c38588dca2b3535ed1a1a2 add initial WIP --- diff --git a/.editorconfig b/.editorconfig index f487ba2..ca2bed3 100644 --- a/.editorconfig +++ b/.editorconfig @@ -9,10 +9,10 @@ end_of_line = lf insert_final_newline = true trim_trailing_whitespace = true -[{**.pl,**.pm,**.pod,**.t,bin/graphql}] +[{**.pl,**.pm,**.pod,**.t,bin/fkpx-agent}] indent_style = space indent_size = 4 -max_line_length = 120 +max_line_length = 110 [{.editorconfig,**.ini}] indent_style = space diff --git a/.perlcriticrc b/.perlcriticrc new file mode 100644 index 0000000..29f0c88 --- /dev/null +++ b/.perlcriticrc @@ -0,0 +1,4 @@ +# We don't really do much using the return value for error-checking. I think +# in this codebase bugs would more likely be in the form if unintentionally +# returning empty list in list context. +[-Subroutines::ProhibitExplicitReturnUndef] diff --git a/Makefile b/Makefile index 8d46f02..2a0c760 100644 --- a/Makefile +++ b/Makefile @@ -4,16 +4,17 @@ CPANM = cpanm COVER = cover DZIL = dzil +PERL = perl PROVE = prove -.PHONY: all bootstrap clean cover dist test +cpanm_env = AUTHOR_TESTING=0 RELEASE_TESTING=0 -all: bootstrap dist +all: dist bootstrap: - $(CPANM) Dist::Zilla - $(DZIL) authordeps --missing | $(CPANM) - $(DZIL) listdeps --develop --missing | $(CPANM) + $(cpanm_env) $(CPANM) -nq Dist::Zilla + $(DZIL) authordeps --missing |$(cpanm_env) $(CPANM) -nq + $(DZIL) listdeps --develop --missing |$(cpanm_env) $(CPANM) -nq clean: $(DZIL) $@ @@ -25,5 +26,14 @@ dist: $(DZIL) build test: - $(PROVE) -l $(if $(V),-v) + $(PROVE) -l $(if $(V),-vj1) +smoke: + smoke-all file-kdbx File-KDBX-$V.tar.gz + +smokers: + $(DZIL) listdeps --no-recommends --no-suggests --no-develop --cpanm-versions \ + |$(PERL) -pe 's/"//g' \ + |build-perl-smokers file-kdbx + +.PHONY: all bootstrap clean cover dist smoke smokers test diff --git a/dist.ini b/dist.ini index 162dc02..7d864d7 100644 --- a/dist.ini +++ b/dist.ini @@ -1,7 +1,59 @@ name = File-KDBX -author = Charles McGarvey +author = Charles McGarvey copyright_holder = Charles McGarvey copyright_year = 2022 license = Perl_5 [@Author::CCM] +:version = 0.011 +; the PerlIO layers are an implementation detail that might change +no_index = lib/PerlIO/via/File/KDBX t xt + +[Prereqs / RuntimeRecommends] +; B::COW might speed up the memory erase feature, maybe +B::COW = 0 +File::Spec = 0 +File::Which = 0 + +[Prereqs / TestSuggests] +POSIX::1003 = 0 + +[OptionalFeature / xs] +-description = speed improvements (requires C compiler) +-prompt = 0 +-always_recommend = 1 +File::KDBX::XS = 0 + +[OptionalFeature / compression] +-description = ability to read and write compressed KDBX files +-prompt = 0 +-always_recommend = 1 +Compress::Raw::Zlib = 0 + +[OptionalFeature / otp] +-description = ability to generate one-time passwords from configured database entries +-prompt = 0 +-always_recommend = 1 +Pass::OTP = 0 + +; https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/berlin-consensus.md#need-for-a-post-install-recommendations-key +; I'd like to suggest File::KeePass::KDBX, but that would create a circular +; dependency. If/when there exists a post-install recommendations key, we can +; use that. +; [OptionalFeature / kdb] +; -description = ability to read and write old KDB files +; -prompt = 0 +; -always_suggests = 1 +; File::KeePass = 0 +; File::KeePass::KDBX = 0 +[Prereqs::Soften / BreakCycle] +to_relationship = none +module = File::KeePass +module = File::KeePass::KDBX + +[Prereqs::Soften] +modules_from_features = 1 + +[Encoding] +encoding = bytes +matches = \.(key|kdbx?)$ diff --git a/lib/File/KDBX.pm b/lib/File/KDBX.pm new file mode 100644 index 0000000..03a055b --- /dev/null +++ b/lib/File/KDBX.pm @@ -0,0 +1,2155 @@ +package File::KDBX; +# ABSTRACT: Encrypted databases to store secret text and files + +use warnings; +use strict; + +use Crypt::PRNG qw(random_bytes); +use Devel::GlobalDestruction; +use File::KDBX::Constants qw(:all); +use File::KDBX::Error; +use File::KDBX::Safe; +use File::KDBX::Util qw(:empty erase generate_uuid search simple_expression_query snakify); +use List::Util qw(any); +use Ref::Util qw(is_ref is_arrayref is_plain_hashref); +use Scalar::Util qw(blessed refaddr); +use Time::Piece; +use boolean; +use warnings::register; +use namespace::clean; + +our $VERSION = '999.999'; # VERSION +our $WARNINGS = 1; + +my %SAFE; +my %KEYS; + +=method new + + $kdbx = File::KDBX->new(%attributes); + $kdbx = File::KDBX->new($kdbx); # copy constructor + +Construct a new L. + +=cut + +sub new { + my $class = shift; + + # copy constructor + return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class); + + my $self = bless {}, $class; + $self->init(@_); + $self->_set_default_attributes if empty $self; + return $self; +} + +sub DESTROY { !in_global_destruction and $_[0]->reset } + +=method init + + $kdbx = $kdbx->init(%attributes); + +Initialize a L with a new set of attributes. Returns itself to allow method chaining. + +This is called by L. + +=cut + +sub init { + my $self = shift; + my %args = @_; + + @$self{keys %args} = values %args; + + return $self; +} + +=method reset + + $kdbx = $kdbx->reset; + +Set a L to an empty state, ready to load a KDBX file or build a new one. Returns itself to allow +method chaining. + +=cut + +sub reset { + my $self = shift; + erase $self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY}; + erase $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY}; + erase $self->{raw}; + %$self = (); + delete $SAFE{refaddr($self)}; + $self->_remove_safe; + return $self; +} + +=method clone + + $kdbx_copy = $kdbx->clone; + $kdbx_copy = File::KDBX->new($kdbx); + +Clone a L. The clone will be an exact copy and completely independent of the original. + +=cut + +sub clone { + my $self = shift; + require Storable; + return Storable::dclone($self); +} + +sub STORABLE_freeze { + my $self = shift; + my $cloning = shift; + + my $copy = {%$self}; + + return '', $copy, $KEYS{refaddr($self)}, $SAFE{refaddr($self)}; +} + +sub STORABLE_thaw { + my $self = shift; + my $cloning = shift; + my $clone = shift; + my $key = shift; + my $safe = shift; + + @$self{keys %$clone} = values %$clone; + $KEYS{refaddr($self)} = $key; + $SAFE{refaddr($self)} = $safe; +} + +############################################################################## + +=method load + +=method load_string + +=method load_file + +=method load_handle + + $kdbx = KDBX::File->load(\$string, $key); + $kdbx = KDBX::File->load(*IO, $key); + $kdbx = KDBX::File->load($filepath, $key); + $kdbx->load(...); # also instance method + + $kdbx = File::KDBX->load_string($string, $key); + $kdbx = File::KDBX->load_string(\$string, $key); + $kdbx->load_string(...); # also instance method + + $kdbx = File::KDBX->load_file($filepath, $key); + $kdbx->load_file(...); # also instance method + + $kdbx = File::KDBX->load_handle($fh, $key); + $kdbx = File::KDBX->load_handle(*IO, $key); + $kdbx->load_handle(...); # also instance method + +Load a KDBX file from a string buffer, IO handle or file from a filesystem. + +L does the heavy lifting. + +=cut + +sub load { shift->_loader->load(@_) } +sub load_string { shift->_loader->load_string(@_) } +sub load_file { shift->_loader->load_file(@_) } +sub load_handle { shift->_loader->load_handle(@_) } + +sub _loader { + my $self = shift; + $self = $self->new if !ref $self; + require File::KDBX::Loader; + File::KDBX::Loader->new(kdbx => $self); +} + +=method dump + +=method dump_string + +=method dump_file + +=method dump_handle + + $kdbx->dump(\$string, $key); + $kdbx->dump(*IO, $key); + $kdbx->dump($filepath, $key); + + $kdbx->dump_string(\$string, $key); + \$string = $kdbx->dump_string($key); + + $kdbx->dump_file($filepath, $key); + + $kdbx->dump_handle($fh, $key); + $kdbx->dump_handle(*IO, $key); + +Dump a KDBX file to a string buffer, IO handle or file in a filesystem. + +L does the heavy lifting. + +=cut + +sub dump { shift->_dumper->dump(@_) } +sub dump_string { shift->_dumper->dump_string(@_) } +sub dump_file { shift->_dumper->dump_file(@_) } +sub dump_handle { shift->_dumper->dump_handle(@_) } + +sub _dumper { + my $self = shift; + $self = $self->new if !ref $self; + require File::KDBX::Dumper; + File::KDBX::Dumper->new(kdbx => $self); +} + +############################################################################## + +=method user_agent_string + + $string = $kdbx->user_agent_string; + +Get a text string identifying the database client software. + +=cut + +sub user_agent_string { + require Config; + sprintf('%s/%s (%s/%s; %s/%s; %s)', + __PACKAGE__, $VERSION, @Config::Config{qw(package version osname osvers archname)}); +} + +=attr sig1 + +=attr sig2 + +=attr version + +=attr headers + +=attr inner_headers + +=attr meta + +=attr binaries + +=attr deleted_objects + +=attr raw + + $value = $kdbx->$attr; + $kdbx->$attr($value); + +Get and set attributes. + +=cut + +my %ATTRS = ( + sig1 => KDBX_SIG1, + sig2 => KDBX_SIG2_2, + version => KDBX_VERSION_3_1, + headers => sub { +{} }, + inner_headers => sub { +{} }, + meta => sub { +{} }, + binaries => sub { +{} }, + deleted_objects => sub { +{} }, + raw => undef, +); +my %ATTRS_HEADERS = ( + HEADER_COMMENT() => '', + HEADER_CIPHER_ID() => CIPHER_UUID_CHACHA20, + HEADER_COMPRESSION_FLAGS() => COMPRESSION_GZIP, + HEADER_MASTER_SEED() => sub { random_bytes(32) }, + # HEADER_TRANSFORM_SEED() => sub { random_bytes(32) }, + # HEADER_TRANSFORM_ROUNDS() => 100_000, + HEADER_ENCRYPTION_IV() => sub { random_bytes(16) }, + # HEADER_INNER_RANDOM_STREAM_KEY() => sub { random_bytes(32) }, # 64? + HEADER_STREAM_START_BYTES() => sub { random_bytes(32) }, + # HEADER_INNER_RANDOM_STREAM_ID() => STREAM_ID_CHACHA20, + HEADER_KDF_PARAMETERS() => sub { + +{ + KDF_PARAM_UUID() => KDF_UUID_AES, + KDF_PARAM_AES_ROUNDS() => $_[0]->headers->{+HEADER_TRANSFORM_ROUNDS} // KDF_DEFAULT_AES_ROUNDS, + KDF_PARAM_AES_SEED() => $_[0]->headers->{+HEADER_TRANSFORM_SEED} // random_bytes(32), + }; + }, + # HEADER_PUBLIC_CUSTOM_DATA() => sub { +{} }, +); +my %ATTRS_META = ( + generator => '', + header_hash => '', + database_name => '', + database_name_changed => sub { gmtime }, + database_description => '', + database_description_changed => sub { gmtime }, + default_username => '', + default_username_changed => sub { gmtime }, + maintenance_history_days => 0, + color => '', + master_key_changed => sub { gmtime }, + master_key_change_rec => -1, + master_key_change_force => -1, + # memory_protection => sub { +{} }, + custom_icons => sub { +{} }, + recycle_bin_enabled => true, + recycle_bin_uuid => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", + recycle_bin_changed => sub { gmtime }, + entry_templates_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", + entry_templates_group_changed => sub { gmtime }, + last_selected_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", + last_top_visible_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", + history_max_items => HISTORY_DEFAULT_MAX_ITEMS, + history_max_size => HISTORY_DEFAULT_MAX_SIZE, + settings_changed => sub { gmtime }, + # binaries => sub { +{} }, + # custom_data => sub { +{} }, +); +my %ATTRS_MEMORY_PROTECTION = ( + protect_title => false, + protect_username => false, + protect_password => true, + protect_url => false, + protect_notes => false, + auto_enable_visual_hiding => false, +); + +sub _update_group_uuid { + my $self = shift; + my $old_uuid = shift // return; + my $new_uuid = shift; + + my $meta = $self->meta; + $self->recycle_bin_uuid($new_uuid) if $old_uuid eq ($meta->{recycle_bin_uuid} // ''); + $self->entry_templates_group($new_uuid) if $old_uuid eq ($meta->{entry_templates_group} // ''); + $self->last_selected_group($new_uuid) if $old_uuid eq ($meta->{last_selected_group} // ''); + $self->last_top_visible_group($new_uuid) if $old_uuid eq ($meta->{last_top_visible_group} // ''); + + for my $group (@{$self->all_groups}) { + $group->last_top_visible_entry($new_uuid) if $old_uuid eq ($group->{last_top_visible_entry} // ''); + $group->previous_parent_group($new_uuid) if $old_uuid eq ($group->{previous_parent_group} // ''); + } + for my $entry (@{$self->all_entries}) { + $entry->previous_parent_group($new_uuid) if $old_uuid eq ($entry->{previous_parent_group} // ''); + } +} + +sub _update_entry_uuid { + my $self = shift; + my $old_uuid = shift // return; + my $new_uuid = shift; + + for my $entry (@{$self->all_entries}) { + $entry->previous_parent_group($new_uuid) if $old_uuid eq ($entry->{previous_parent_group} // ''); + } +} + +while (my ($attr, $default) = each %ATTRS) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$attr} = sub { + my $self = shift; + $self->{$attr} = shift if @_; + $self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} +while (my ($attr, $default) = each %ATTRS_HEADERS) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$attr} = sub { + my $self = shift; + $self->headers->{$attr} = shift if @_; + $self->headers->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} +while (my ($attr, $default) = each %ATTRS_META) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$attr} = sub { + my $self = shift; + $self->meta->{$attr} = shift if @_; + $self->meta->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} +while (my ($attr, $default) = each %ATTRS_MEMORY_PROTECTION) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$attr} = sub { + my $self = shift; + $self->meta->{$attr} = shift if @_; + $self->meta->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} + +my @ATTRS_OTHER = ( + HEADER_TRANSFORM_SEED, + HEADER_TRANSFORM_ROUNDS, + HEADER_INNER_RANDOM_STREAM_KEY, + HEADER_INNER_RANDOM_STREAM_ID, +); +sub _set_default_attributes { + my $self = shift; + $self->$_ for keys %ATTRS, keys %ATTRS_HEADERS, keys %ATTRS_META, keys %ATTRS_MEMORY_PROTECTION, + @ATTRS_OTHER; +} + +=method memory_protection + + \%settings = $kdbx->memory_protection + $kdbx->memory_protection(\%settings); + + $bool = $kdbx->memory_protection($string_key); + $kdbx->memory_protection($string_key => $bool); + +Get or set memory protection settings. This globally (for the whole database) configures whether and which of +the standard strings should be memory-protected. The default setting is to memory-protect only I +strings. + +Memory protection can be toggled individually for each entry string, and individual settings take precedence +over these global settings. + +=cut + +sub memory_protection { + my $self = shift; + $self->{meta}{memory_protection} = shift if @_ == 1 && is_plain_hashref($_[0]); + return $self->{meta}{memory_protection} //= {} if !@_; + + my $string_key = shift; + my $key = 'protect_' . lc($string_key); + + $self->meta->{memory_protection}{$key} = shift if @_; + $self->meta->{memory_protection}{$key}; +} + +=method minimum_version + + $version = $kdbx->minimum_version; + +Determine the minimum file version required to save a database losslessly. Using certain databases features +might increase this value. For example, setting the KDF to Argon2 will increase the minimum version to at +least C (i.e. C<0x00040000>) because Argon2 was introduced with KDBX4. + +This method never returns less than C (i.e. C<0x00030001>). That file version is so +ubiquitious and well-supported, there are seldom reasons to dump in a lesser format nowadays. + +B If you dump a database with a minimum version higher than the current L, the dumper will +typically issue a warning and automatically upgrade the database. This seems like the safest behavior in order +to avoid data loss, but lower versions have the benefit of being compatible with more software. It is possible +to prevent auto-upgrades by explicitly telling the dumper which version to use, but you do run the risk of +data loss. A database will never be automatically downgraded. + +=cut + +sub minimum_version { + my $self = shift; + + return KDBX_VERSION_4_1 if any { + nonempty $_->{last_modification_time} + } values %{$self->custom_data}; + + return KDBX_VERSION_4_1 if any { + nonempty $_->{name} || nonempty $_->{last_modification_time} + } values %{$self->custom_icons}; + + return KDBX_VERSION_4_1 if any { + nonempty $_->previous_parent_group || nonempty $_->tags || + any { nonempty $_->{last_modification_time} } values %{$_->custom_data} + } @{$self->all_groups}; + + 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}; + + return KDBX_VERSION_4_0 if $self->kdf->uuid ne KDF_UUID_AES; + + return KDBX_VERSION_4_0 if nonempty $self->public_custom_data; + + return KDBX_VERSION_4_0 if any { + nonempty $_->custom_data + } @{$self->all_groups}, @{$self->all_entries}; + + return KDBX_VERSION_3_1; +} + +############################################################################## + +=method add_group + + +=cut + +sub add_group { + my $self = shift; + my $group = @_ % 2 == 1 ? shift : undef; + my %args = @_; + + my $parent = delete $args{group} // delete $args{parent} // $self->root; + ($parent) = $self->find_groups({uuid => $parent}) if !ref $parent; + + $group = $self->_group($group // [%args]); + $group->uuid; + + return $parent->add_group($group); +} + +sub _group { + my $self = shift; + my $group = shift; + require File::KDBX::Group; + return File::KDBX::Group->wrap($group, $self); +} + +=method root + + $group = $kdbx->root; + $kdbx->root($group); + +Get or set a database's root group. You don't necessarily need to explicitly create or set a root group +because it autovivifies when adding entries and groups to the database. + +Every database has only a single root group at a time. Some old KDB files might have multiple root groups. +When reading such files, a single implicit root group is created to contain the other explicit groups. When +writing to such a format, if the root group looks like it was implicitly created then it won't be written and +the resulting file might have multiple root groups. This allows working with older files without changing +their written internal structure while still adhering to the modern restrictions while the database is opened. + +B The root group of a KDBX database contains all of the database's entries and other groups. If you +replace the root group, you are essentially replacing the entire database contents with something else. + +=cut + +sub root { + my $self = shift; + if (@_) { + $self->{root} = $self->_group(@_); + $self->{root}->kdbx($self); + } + $self->{root} //= $self->_implicit_root; + return $self->_group($self->{root}); +} + +sub _kpx_groups { + my $self = shift; + return [] if !$self->{root}; + return $self->_is_implicit_root ? $self->root->groups : [$self->root]; +} + +sub _is_implicit_root { + my $self = shift; + my $root = $self->root; + my $temp = __PACKAGE__->_implicit_root; + # If an implicit root group has been changed in any significant way, it is no longer implicit. + return $root->name eq $temp->name && + $root->is_expanded ^ $temp->is_expanded && + $root->notes eq $temp->notes && + !@{$root->entries} && + !defined $root->custom_icon_uuid && + !keys %{$root->custom_data} && + $root->icon_id == $temp->icon_id && + $root->expires ^ $temp->expires && + $root->default_auto_type_sequence eq $temp->default_auto_type_sequence && + !defined $root->enable_auto_type && + !defined $root->enable_searching; +} + +sub _implicit_root { + my $self = shift; + require File::KDBX::Group; + return File::KDBX::Group->new( + name => 'Root', + is_expanded => true, + notes => 'Added as an implicit root group by '.__PACKAGE__.'.', + ref $self ? (kdbx => $self) : (), + ); +} + +=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); + \@groups = $kdbx->all_groups($base_group, %options); + +Get all groups deeply in a database, or all groups within a specified base group, in a flat array. Supported +options: + +=for :list +* C - Only include groups within a base group (same as C<$base_group>) (default: root) +* C - Include the base group in the results (default: true) + +=cut + +sub all_groups { + my $self = shift; + my %args = @_ % 2 == 0 ? @_ : (base => shift, @_); + my $base = $args{base} // $self->root; + + my @groups = $args{include_base} // 1 ? $self->_group($base) : (); + + for my $subgroup (@{$base->{groups} || []}) { + my $more = $self->all_groups($subgroup); + push @groups, @$more; + } + + return \@groups; +} + +=method trace_lineage + + \@lineage = $kdbx->trace_lineage($group); + \@lineage = $kdbx->trace_lineage($group, $base_group); + \@lineage = $kdbx->trace_lineage($entry); + \@lineage = $kdbx->trace_lineage($entry, $base_group); + +Get the direct line of ancestors from C<$base_group> (default: the root group) to a group or entry. The +lineage includes the base group but I the target group or entry. Returns C if the target is not in +the database structure. + +=cut + +sub trace_lineage { + my $self = shift; + my $thing = shift; + my @lineage = @_; + + push @lineage, $self->root if !@lineage; + my $base = $lineage[-1]; + + my $uuid = $thing->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); + return $result if $result; + } +} + +=method find_groups + + @groups = $kdbx->find_groups($query, %options); + +Find all groups deeply that match to a query. Options are the same as for L. + +See L for a description of what C<$query> can be. + +=cut + +sub find_groups { + my $self = shift; + my $query = shift or throw 'Must provide a query'; + my %args = @_; + my %all_groups = ( + base => $args{base}, + include_base => $args{include_base}, + ); + return @{search($self->all_groups(%all_groups), is_arrayref($query) ? @$query : $query)}; +} + +sub remove { + my $self = shift; + my $object = shift; +} + +############################################################################## + +=method add_entry + + +=cut + +sub add_entry { + my $self = shift; + my $entry = @_ % 2 == 1 ? shift : undef; + my %args = @_; + + my $parent = delete $args{group} // delete $args{parent} // $self->root; + ($parent) = $self->find_groups({uuid => $parent}) if !ref $parent; + + $entry = $self->_entry($entry // delete $args{entry} // [%args]); + $entry->uuid; + + return $parent->add_entry($entry); +} + +sub _entry { + my $self = shift; + my $entry = shift; + require File::KDBX::Entry; + return File::KDBX::Entry->wrap($entry, $self); +} + +=method all_entries + + \@entries = $kdbx->all_entries(%options); + \@entries = $kdbx->all_entries($base_group, %options); + +Get entries deeply in a database, in a flat array. Supported options: + +=for :list +* C - Only include entries within a base group (same as C<$base_group>) (default: root) +* C - Only include entries with auto-type enabled (default: false, include all) +* C - Only include entries within groups with search enabled (default: false, include all) +* C - Also include historical entries (default: false, include only active entries) + +=cut + +sub all_entries { + my $self = shift; + my %args = @_ % 2 == 0 ? @_ : (base => shift, @_); + + my $base = $args{base} // $self->root; + my $history = $args{history}; + my $search = $args{search}; + my $auto_type = $args{auto_type}; + + my $enable_auto_type = $base->{enable_auto_type} // true; + my $enable_searching = $base->{enable_searching} // true; + + my @entries; + if ((!$search || $enable_searching) && (!$auto_type || $enable_auto_type)) { + push @entries, + map { $self->_entry($_) } + grep { !$auto_type || $_->{auto_type}{enabled} } + map { $_, $history ? @{$_->{history} || []} : () } + @{$base->{entries} || []}; + } + + for my $subgroup (@{$base->{groups} || []}) { + my $more = $self->all_entries($subgroup, + auto_type => $auto_type, + search => $search, + history => $history, + ); + push @entries, @$more; + } + + return \@entries; +} + +=method find_entries + +=method find_entries_simple + + @entries = $kdbx->find_entries($query, %options); + + @entries = $kdbx->find_entries_simple($expression, \@fields, %options); + @entries = $kdbx->find_entries_simple($expression, $operator, \@fields, %options); + +Find all entries deeply that match a query. Options are the same as for L. + +See L for a description of what C<$query> can be. + +=cut + +sub find_entries { + my $self = shift; + 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}, + ); + return @{search($self->all_entries(%all_entries), is_arrayref($query) ? @$query : $query)}; +} + +sub find_entries_simple { + my $self = shift; + my $text = shift; + my $op = @_ && !is_ref($_[0]) ? shift : undef; + my $fields = shift; + is_arrayref($fields) or throw q{Usage: find_entries_simple($expression, [$op,] \@fields)}; + return $self->find_entries([\$text, $op, $fields], @_); +} + +############################################################################## + +=method custom_icon + + \%icon = $kdbx->custom_icon($uuid); + $kdbx->custom_icon($uuid => \%icon); + $kdbx->custom_icon(%icon); + $kdbx->custom_icon(uuid => $value, %icon); + + +=cut + +sub custom_icon { + my $self = shift; + my %args = @_ == 2 ? (uuid => shift, value => shift) + : @_ % 2 == 1 ? (uuid => shift, @_) : @_; + + if (!$args{key} && !$args{value}) { + my %standard = (key => 1, value => 1, last_modification_time => 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 = $args{key} or throw 'Must provide a custom_icons key to access'; + + return $self->{meta}{custom_icons}{$key} = $args{value} if is_plain_hashref($args{value}); + + while (my ($field, $value) = each %args) { + $self->{meta}{custom_icons}{$key}{$field} = $value; + } + return $self->{meta}{custom_icons}{$key}; +} + +=method custom_icon_data + + $image_data = $kdbx->custom_icon_data($uuid); + +Get a custom icon. + +=cut + +sub custom_icon_data { + my $self = shift; + my $uuid = shift // return; + return if !exists $self->custom_icons->{$uuid}; + return $self->custom_icons->{$uuid}{data}; +} + +=method add_custom_icon + + $uuid = $kdbx->add_custom_icon($image_data, %attributes); + +Add a custom icon and get its UUID. If not provided, a random UUID will be generated. Possible attributes: + +=for :list +* C - Icon UUID +* C - Name of the icon (text, KDBX4.1+) +* C - Just what it says (datetime, KDBX4.1+) + +=cut + +sub add_custom_icon { + my $self = shift; + my $img = shift or throw 'Must provide image data'; + my %args = @_; + + my $uuid = $args{uuid} // generate_uuid(sub { !$self->custom_icons->{$_} }); + $self->custom_icons->{$uuid} = { + @_, + uuid => $uuid, + data => $img, + }; + return $uuid; +} + +=method remove_custom_icon + + $kdbx->remove_custom_icon($uuid); + +Remove a custom icon. + +=cut + +sub remove_custom_icon { + my $self = shift; + my $uuid = shift; + delete $self->custom_icons->{$uuid}; +} + +############################################################################## + +=method custom_data + + \%all_data = $kdbx->custom_data; + $kdbx->custom_data(\%all_data); + + \%data = $kdbx->custom_data($key); + $kdbx->custom_data($key => \%data); + $kdbx->custom_data(%data); + $kdbx->custom_data(key => $value, %data); + +Get and set custom data. Custom data is metadata associated with a database. + +Each data item can have a few attributes associated with it. + +=for :list +* C - A unique text string identifier used to look up the data item (required) +* C - A text string value (required) +* C (optional, KDBX4.1+) + +=cut + +sub custom_data { + my $self = shift; + $self->{meta}{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]); + return $self->{meta}{custom_data} //= {} if !@_; + + my %args = @_ == 2 ? (key => shift, value => shift) + : @_ % 2 == 1 ? (key => shift, @_) : @_; + + if (!$args{key} && !$args{value}) { + my %standard = (key => 1, value => 1, last_modification_time => 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 = $args{key} or throw 'Must provide a custom_data key to access'; + + return $self->{meta}{custom_data}{$key} = $args{value} if is_plain_hashref($args{value}); + + while (my ($field, $value) = each %args) { + $self->{meta}{custom_data}{$key}{$field} = $value; + } + return $self->{meta}{custom_data}{$key}; +} + +=method custom_data_value + + $value = $kdbx->custom_data_value($key); + +Exactly the same as L except returns just the custom data's value rather than a structure of +attributes. This is a shortcut for: + + my $data = $kdbx->custom_data($key); + my $value = defined $data ? $data->{value} : undef; + +=cut + +sub custom_data_value { + my $self = shift; + my $data = $self->custom_data(@_) // return; + return $data->{value}; +} + +=method public_custom_data + + \%all_data = $kdbx->public_custom_data; + $kdbx->public_custom_data(\%all_data); + + $value = $kdbx->public_custom_data($key); + $kdbx->public_custom_data($key => $value); + +Get and set public custom data. Public custom data is similar to custom data but different in some important +ways. Public custom data: + +=for :list +* can store strings, booleans and up to 64-bit integer values (custom data can only store text values) +* is NOT encrypted within a KDBX file (hence the "public" part of the name) +* is a flat hash/dict of key-value pairs (no other associated fields like modification times) + +=cut + +sub public_custom_data { + my $self = shift; + $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA} = shift if @_ == 1 && is_plain_hashref($_[0]); + return $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA} //= {} if !@_; + + my $key = shift or throw 'Must provide a public_custom_data key to access'; + $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA}{$key} = shift if @_; + return $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA}{$key}; +} + +############################################################################## + +# TODO + +# sub merge_to { +# my $self = shift; +# my $other = shift; +# my %options = @_; # prefer_old / prefer_new +# $other->merge_from($self); +# } + +# sub merge_from { +# my $self = shift; +# my $other = shift; + +# die 'Not implemented'; +# } + +############################################################################## + +=method resolve_reference + + $string = $kdbx->resolve_reference($reference); + $string = $kdbx->resolve_reference($wanted, $search_in, $expression); + +Resolve a L. A field reference is a kind of +string placeholder. You can use a field reference to refer directly to a standard field within an entry. Field +references are resolved automatically while expanding entry strings (i.e. replacing placeholders), but you can +use this method to resolve on-the-fly references that aren't part of any actual string in the database. + +If the reference does not resolve to any field, C is returned. If the reference resolves to multiple +fields, only the first one is returned (in the same order as L). To avoid ambiguity, you can +refer to a specific entry by its UUID. + +The syntax of a reference is: C<< {REF:@:} >>. C is a +L. C and C are both single character codes representing a field: + +=for :list +* C - Title +* C - UserName +* C

- Password +* C - URL +* C - Notes +* C - UUID +* C - Other custom strings + +Since C does not represent any specific field, it cannot be used as the C. + +Examples: + +To get the value of the I string of the first entry with "My Bank" in the title: + + my $username = $kdbx->resolve_reference('{REF:U@T:"My Bank"}'); + # OR the {REF:...} wrapper is optional + my $username = $kdbx->resolve_reference('U@T:"My Bank"'); + # OR separate the arguments + my $username = $kdbx->resolve_reference(U => T => '"My Bank"'); + +Note how the text is a L, so search terms with spaces must be surrounded in double +quotes. + +To get the I string of a specific entry (identified by its UUID): + + my $password = $kdbx->resolve_reference('{REF:P@I:46C9B1FFBD4ABC4BBB260C6190BAD20C}'); + +=cut + +sub resolve_reference { + my $self = shift; + my $wanted = shift // return; + my $search_in = shift; + my $text = shift; + + if (!defined $text) { + $wanted =~ s/^\{REF:([^\}]+)\}$/$1/i; + ($wanted, $search_in, $text) = $wanted =~ /^([TUPANI])\@([TUPANIO]):(.*)$/i; + } + $wanted && $search_in && nonempty($text) or return; + + my %fields = ( + T => 'expanded_title', + U => 'expanded_username', + P => 'expanded_password', + A => 'expanded_url', + N => 'expanded_notes', + I => 'id', + O => 'other_strings', + ); + $wanted = $fields{$wanted} or return; + $search_in = $fields{$search_in} or return; + + my $query = simple_expression_query($text, ($search_in eq 'id' ? 'eq' : '=~'), $search_in); + + my ($entry) = $self->find_entries($query); + $entry or return; + + return $entry->$wanted; +} + +our %PLACEHOLDERS = ( + # placeholder => sub { my ($entry, $arg) = @_; ... }; + 'TITLE' => sub { $_[0]->expanded_title }, + 'USERNAME' => sub { $_[0]->expanded_username }, + 'PASSWORD' => sub { $_[0]->expanded_password }, + 'NOTES' => sub { $_[0]->expanded_notes }, + 'S:' => sub { $_[0]->string_value($_[1]) }, + 'URL' => sub { $_[0]->expanded_url }, + 'URL:RMVSCM' => sub { local $_ = $_[0]->url; s!^[^:/\?\#]+://!!; $_ }, + 'URL:WITHOUTSCHEME' => sub { local $_ = $_[0]->url; s!^[^:/\?\#]+://!!; $_ }, + 'URL:SCM' => sub { (split_url($_[0]->url))[0] }, + 'URL:SCHEME' => sub { (split_url($_[0]->url))[0] }, # non-standard + 'URL:HOST' => sub { (split_url($_[0]->url))[2] }, + 'URL:PORT' => sub { (split_url($_[0]->url))[3] }, + 'URL:PATH' => sub { (split_url($_[0]->url))[4] }, + 'URL:QUERY' => sub { (split_url($_[0]->url))[5] }, + 'URL:HASH' => sub { (split_url($_[0]->url))[6] }, # non-standard + 'URL:FRAGMENT' => sub { (split_url($_[0]->url))[6] }, # non-standard + 'URL:USERINFO' => sub { (split_url($_[0]->url))[1] }, + 'URL:USERNAME' => sub { (split_url($_[0]->url))[7] }, + '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') }, + 'APPDIR' => sub { load_optional('FindBin'); $FindBin::Bin }, + 'GROUP' => sub { $_[0]->parent->name }, + 'GROUP_PATH' => sub { $_[0]->path }, + 'GROUP_NOTES' => sub { $_[0]->parent->notes }, + # 'GROUP_SEL' + # 'GROUP_SEL_PATH' + # 'GROUP_SEL_NOTES' + # 'DB_PATH' + # 'DB_DIR' + # 'DB_NAME' + # 'DB_BASENAME' + # 'DB_EXT' + 'ENV:' => sub { $ENV{$_[1]} }, + 'ENV_DIRSEP' => sub { load_optional('File::Spec')->catfile('', '') }, + 'ENV_PROGRAMFILES_X86' => sub { $ENV{'ProgramFiles(x86)'} || $ENV{'ProgramFiles'} }, + # 'T-REPLACE-RX:' + # 'T-CONV:' + 'DT_SIMPLE' => sub { localtime->strftime('%Y%m%d%H%M%S') }, + 'DT_YEAR' => sub { localtime->strftime('%Y') }, + 'DT_MONTH' => sub { localtime->strftime('%m') }, + 'DT_DAY' => sub { localtime->strftime('%d') }, + 'DT_HOUR' => sub { localtime->strftime('%H') }, + 'DT_MINUTE' => sub { localtime->strftime('%M') }, + 'DT_SECOND' => sub { localtime->strftime('%S') }, + 'DT_UTC_SIMPLE' => sub { gmtime->strftime('%Y%m%d%H%M%S') }, + 'DT_UTC_YEAR' => sub { gmtime->strftime('%Y') }, + 'DT_UTC_MONTH' => sub { gmtime->strftime('%m') }, + 'DT_UTC_DAY' => sub { gmtime->strftime('%d') }, + 'DT_UTC_HOUR' => sub { gmtime->strftime('%H') }, + 'DT_UTC_MINUTE' => sub { gmtime->strftime('%M') }, + 'DT_UTC_SECOND' => sub { gmtime->strftime('%S') }, + # 'PICKCHARS' + # 'PICKCHARS:' + # 'PICKFIELD' + # 'NEWPASSWORD' + # 'NEWPASSWORD:' + # 'PASSWORD_ENC' + 'HMACOTP' => sub { $_[0]->hmac_otp }, + 'TIMEOTP' => sub { $_[0]->time_otp }, + 'C:' => sub { '' }, # comment + # 'BASE' + # 'BASE:' + # 'CLIPBOARD' + # 'CLIPBOARD-SET:' + # 'CMD:' +); + +############################################################################## + +=method lock + + $kdbx->lock; + +Encrypt all protected strings in a database. The encrypted strings are stored in a L +associated with the database and the actual strings will be replaced with C to indicate their protected +state. Returns itself to allow method chaining. + +=cut + +sub _safe { + my $self = shift; + $SAFE{refaddr($self)} = shift if @_; + $SAFE{refaddr($self)}; +} + +sub _remove_safe { delete $SAFE{refaddr($_[0])} } + +sub lock { + my $self = shift; + + $self->_safe and return $self; + + my @strings; + + my $entries = $self->all_entries(history => 1); + for my $entry (@$entries) { + push @strings, grep { $_->{protect} } values %{$entry->{strings} || {}}; + } + + $self->_safe(File::KDBX::Safe->new(\@strings)); + + return $self; +} + +=method unlock + + $kdbx->unlock; + +Decrypt all protected strings in a database, replacing C placeholders with unprotected values. Returns +itself to allow method chaining. + +=cut + +sub peek { + my $self = shift; + my $string = shift; + my $safe = $self->_safe or return; + return $safe->peek($string); +} + +sub unlock { + my $self = shift; + my $safe = $self->_safe or return $self; + + $safe->unlock; + $self->_remove_safe; + + return $self; +} + +# sub unlock_scoped { +# my $self = shift; +# return if !$self->is_locked; +# require Scope::Guard; +# my $guard = Scope::Guard->new(sub { $self->lock }); +# $self->unlock; +# return $guard; +# } + +=method is_locked + + $bool = $kdbx->is_locked; + +Get whether or not a database's strings are memory-protected. If this is true, then some or all of the +protected strings within the database will be unavailable (literally have C values) until L is +called. + +=cut + +sub is_locked { $_[0]->_safe ? 1 : 0 } + +############################################################################## + +=method randomize_seeds + + $kdbx->randomize_seeds; + +Set various keys, seeds and IVs to random values. These values are used by the cryptographic functions that +secure the database when dumped. The attributes that will be randomized are: + +=for :list +* L +* L +* L +* L +* L + +Randomizing these values has no effect on a loaded database. These are only used when a database is dumped. +You normally do not need to call this method explicitly because the dumper does it explicitly by default. + +=cut + +sub randomize_seeds { + my $self = shift; + $self->encryption_iv(random_bytes(16)); + $self->inner_random_stream_key(random_bytes(64)); + $self->master_seed(random_bytes(32)); + $self->stream_start_bytes(random_bytes(32)); + $self->transform_seed(random_bytes(32)); +} + +############################################################################## + +=method key + + $key = $kdbx->key; + $key = $kdbx->key($key); + $key = $kdbx->key($primitive); + +Get or set a L. This is the master key (i.e. a password or a key file that can decrypt +a database). See L for an explanation of what the primitive can be. + +You generally don't need to call this directly because you can provide the key directly to the loader or +dumper when loading or saving a KDBX file. + +=cut + +sub key { + my $self = shift; + $KEYS{refaddr($self)} = File::KDBX::Key->new(@_) if @_; + $KEYS{refaddr($self)}; +} + +=method composite_key + + $key = $kdbx->composite_key($key); + $key = $kdbx->composite_key($primitive); + +Construct a L from a primitive. See L for an explanation of +what the primitive can be. If the primitive does not represent a composite key, it will be wrapped. + +You generally don't need to call this directly. The parser and writer use it to transform a master key into +a raw encryption key. + +=cut + +sub composite_key { + my $self = shift; + require File::KDBX::Key::Composite; + return File::KDBX::Key::Composite->new(@_); +} + +=method kdf + + $kdf = $kdbx->kdf(%options); + $kdf = $kdbx->kdf(\%parameters, %options); + +Get a L (key derivation function). + +Options: + +=for :list +* C - KDF parameters, same as C<\%parameters> (default: value of L) + +=cut + +sub kdf { + my $self = shift; + my %args = @_ % 2 == 1 ? (params => shift, @_) : @_; + + my $params = $args{params}; + my $compat = $args{compatible} // 1; + + $params //= $self->kdf_parameters; + $params = {%{$params || {}}}; + + if (empty $params || !defined $params->{+KDF_PARAM_UUID}) { + $params->{+KDF_PARAM_UUID} = KDF_UUID_AES; + } + if ($params->{+KDF_PARAM_UUID} eq KDF_UUID_AES) { + # AES_CHALLENGE_RESPONSE is equivalent to AES if there are no challenge-response keys, and since + # non-KeePassXC implementations don't support challenge-response keys anyway, there's no problem with + # always using AES_CHALLENGE_RESPONSE for all KDBX4+ databases. + # For compatibility, we should not *write* AES_CHALLENGE_RESPONSE, but the dumper handles that. + if ($self->version >= KDBX_VERSION_4_0) { + $params->{+KDF_PARAM_UUID} = KDF_UUID_AES_CHALLENGE_RESPONSE; + } + $params->{+KDF_PARAM_AES_SEED} //= $self->transform_seed; + $params->{+KDF_PARAM_AES_ROUNDS} //= $self->transform_rounds; + } + + require File::KDBX::KDF; + return File::KDBX::KDF->new(%$params); +} + +sub transform_seed { + my $self = shift; + $self->headers->{+HEADER_TRANSFORM_SEED} = + $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_SEED} = shift if @_; + $self->headers->{+HEADER_TRANSFORM_SEED} = + $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_SEED} //= random_bytes(32); +} + +sub transform_rounds { + my $self = shift; + $self->headers->{+HEADER_TRANSFORM_ROUNDS} = + $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_ROUNDS} = shift if @_; + $self->headers->{+HEADER_TRANSFORM_ROUNDS} = + $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_ROUNDS} //= 100_000; +} + +=method cipher + + $cipher = $kdbx->cipher(key => $key); + $cipher = $kdbx->cipher(key => $key, iv => $iv, uuid => $uuid); + +Get a L capable of encrypting and decrypting the body of a database file. + +A key is required. This should be a raw encryption key made up of a fixed number of octets (depending on the +cipher), not a L or primitive. + +If not passed, the UUID comes from C<< $kdbx->headers->{cipher_id} >> and the encryption IV comes from +C<< $kdbx->headers->{encryption_iv} >>. + +You generally don't need to call this directly. The parser and writer use it to decrypt and encrypt KDBX +files. + +=cut + +sub cipher { + my $self = shift; + my %args = @_; + + $args{uuid} //= $self->headers->{+HEADER_CIPHER_ID}; + $args{iv} //= $self->headers->{+HEADER_ENCRYPTION_IV}; + + require File::KDBX::Cipher; + return File::KDBX::Cipher->new(%args); +} + +=method random_stream + + $cipher = $kdbx->random_stream; + $cipher = $kdbx->random_stream(id => $stream_id, key => $key); + +Get a L for decrypting and encrypting protected values. + +If not passed, the ID and encryption key comes from C<< $kdbx->headers->{inner_random_stream_id} >> and +C<< $kdbx->headers->{inner_random_stream_key} >> (respectively) for KDBX3 files and from +C<< $kdbx->inner_headers->{inner_random_stream_key} >> and +C<< $kdbx->inner_headers->{inner_random_stream_id} >> (respectively) for KDBX4 files. + +You generally don't need to call this directly. The parser and writer use it to scramble protected strings. + +=cut + +sub random_stream { + my $self = shift; + my %args = @_; + + $args{stream_id} //= delete $args{id} // $self->inner_random_stream_id; + $args{key} //= $self->inner_random_stream_key; + + require File::KDBX::Cipher; + File::KDBX::Cipher->new(%args); +} + +sub inner_random_stream_id { + my $self = shift; + $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_ID} + = $self->headers->{+HEADER_INNER_RANDOM_STREAM_ID} = shift if @_; + $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_ID} + //= $self->headers->{+HEADER_INNER_RANDOM_STREAM_ID} //= do { + my $version = $self->minimum_version; + $version < KDBX_VERSION_4_0 ? STREAM_ID_SALSA20 : STREAM_ID_CHACHA20; + }; +} + +sub inner_random_stream_key { + my $self = shift; + if (@_) { + # These are probably the same SvPV so erasing one will CoW, but erasing the second should do the + # trick anyway. + erase \$self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY}; + erase \$self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY}; + $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY} + = $self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY} = shift; + } + $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY} + //= $self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY} //= random_bytes(64); # 32 +} + +######################################################################################### + +sub check { +# - Fixer tool. Can repair inconsistencies, including: +# - Orphaned binaries... not really a thing anymore since we now distribute binaries amongst entries +# - Unused custom icons (OFF, data loss) +# - Duplicate icons +# - All data types are valid +# - date times are correct +# - boolean fields +# - All UUIDs refer to things that exist +# - previous parent group +# - recycle bin +# - last selected group +# - last visible group +# - Enforce history size limits (ON) +# - Check headers/meta (ON) +# - Duplicate deleted objects (ON) +# - Duplicate window associations (OFF) +# - Only one root group (ON) + # - Header UUIDs match known ciphers/KDFs? +} + +######################################################################################### + +=attr comment + +A text string associated with the database. Often unset. + +=attr cipher_id + +The UUID of a cipher used to encrypt the database when stored as a file. + +See L. + +=attr compression_flags + +Configuration for whether or not and how the database gets compressed. See +L. + +=attr master_seed + +The master seed is a string of 32 random bytes that is used as salt in hashing the master key when loading +and saving the database. If a challenge-response key is used in the master key, the master seed is also the +challenge. + +The master seed I be changed each time the database is saved to file. + +=attr transform_seed + +The transform seed is a string of 32 random bytes that is used in the key derivation function, either as the +salt or the key (depending on the algorithm). + +The transform seed I be changed each time the database is saved to file. + +=attr transform_rounds + +The number of rounds or iterations used in the key derivation function. Increasing this number makes loading +and saving the database slower by design in order to make dictionary and brute force attacks more costly. + +=attr encryption_iv + +The initialization vector used by the cipher. + +The encryption IV I be changed each time the database is saved to file. + +=attr inner_random_stream_key + +The encryption key (possibly including the IV, depending on the cipher) used to encrypt the protected strings +within the database. + +=attr stream_start_bytes + +A string of 32 random bytes written in the header and encrypted in the body. If the bytes do not match when +loading a file then the wrong master key was used or the file is corrupt. Only KDBX 2 and KDBX 3 files use +this. KDBX 4 files use an improved HMAC method to verify the master key and data integrity of the header and +entire file body. + +=attr inner_random_stream_id + +A number indicating the cipher algorithm used to encrypt the protected strings within the database, usually +Salsa20 or ChaCha20. See L. + +=attr kdf_parameters + +A hash/dict of key-value pairs used to configure the key derivation function. This is the KDBX4+ way to +configure the KDF, superceding L and L. + +=attr generator + +The name of the software used to generate the KDBX file. + +=attr header_hash + +The header hash used to verify that the file header is not corrupt. (KDBX 2 - KDBX 3.1, removed KDBX 4.0) + +=attr database_name + +Name of the database. + +=attr database_name_changed + +Timestamp indicating when the database name was last changed. + +=attr database_description + +Description of the database + +=attr database_description_changed + +Timestamp indicating when the database description was last changed. + +=attr default_username + +When a new entry is created, the I string will be populated with this value. + +=attr default_username_changed + +Timestamp indicating when the default username was last changed. + +=attr maintenance_history_days + +TODO... not really sure what this is. 😀 + +=attr color + +A color associated with the database (in the form C<#ffffff> where "f" is a hexidecimal digit). Some agents +use this to help users visually distinguish between different databases. + +=attr master_key_changed + +Timestamp indicating when the master key was last changed. + +=attr master_key_change_rec + +Number of days until the agent should prompt to recommend changing the master key. + +=attr master_key_change_force + +Number of days until the agent should prompt to force changing the master key. + +Note: This is purely advisory. It is up to the individual agent software to actually enforce it. +C does NOT enforce it. + +=attr recycle_bin_enabled + +Boolean indicating whether removed groups and entries should go to a recycle bin or be immediately deleted. + +=attr recycle_bin_uuid + +The UUID of a group used to store thrown-away groups and entries. + +=attr recycle_bin_changed + +Timestamp indicating when the recycle bin was last changed. + +=attr entry_templates_group + +The UUID of a group containing template entries used when creating new entries. + +=attr entry_templates_group_changed + +Timestamp indicating when the entry templates group was last changed. + +=attr last_selected_group + +The UUID of the previously-selected group. + +=attr last_top_visible_group + +The UUID of the group visible at the top of the list. + +=attr history_max_items + +The maximum number of historical entries allowed to be saved for each entry. + +=attr history_max_size + +The maximum total size (in bytes) that each individual entry's history is allowed to grow. + +=attr settings_changed + +Timestamp indicating when the database settings were last updated. + +=attr protect_title + +Alias of the L setting for the I string. + +=attr protect_username + +Alias of the L</memory_protection> setting for the I<UserName> string. + +=attr protect_password + +Alias of the L</memory_protection> setting for the I<Password> string. + +=attr protect_url + +Alias of the L</memory_protection> setting for the I<URL> string. + +=attr protect_notes + +Alias of the L</memory_protection> setting for the I<Notes> string. + +=cut + +######################################################################################### + +sub TO_JSON { +{%{$_[0]}} } + +1; +__END__ + +=for Pod::Coverage TO_JSON + +=head1 SYNOPSIS + + use File::KDBX; + + my $kdbx = File::KDBX->new; + + my $group = $kdbx->add_group( + name => 'Passwords', + ); + + my $entry = $group->add_entry( + title => 'My Bank', + password => 's3cr3t', + ); + + $kdbx->dump_file('passwords.kdbx', 'M@st3rP@ssw0rd!'); + + $kdbx = File::KDBX->load_file('passwords.kdbx', 'M@st3rP@ssw0rd!'); + + for my $entry (@{ $kdbx->all_entries }) { + say 'Entry: ', $entry->title; + } + +=head1 DESCRIPTION + +B<File::KDBX> provides everything you need to work with a KDBX database. A KDBX database is a hierarchical +object database which is commonly used to store secret information securely. It was developed for the KeePass +password safe. See L</"KDBX Introduction"> for more information about KDBX. + +This module lets you query entries, create new entries, delete entries and modify entries. The distribution +also includes various parsers and generators for serializing and persisting databases. + +This design of this software was influenced by the L<KeePassXC|https://github.com/keepassxreboot/keepassxc> +implementation of KeePass as well as the L<File::KeePass> module. B<File::KeePass> is an alternative module +that works well in most cases but has a small backlog of bugs and security issues and also does not work with +newer KDBX version 4 files. If you're coming here from the B<File::KeePass> world, you might be interested in +L<File::KeePass::KDBX> that is a drop-in replacement for B<File::KeePass> that uses B<File::KDBX> for storage. + +=head2 KDBX Introduction + +A KDBX database consists of a hierarchical I<group> of I<entries>. Entries can contain zero or more key-value +pairs of I<strings> and zero or more I<binaries> (i.e. octet strings). Groups, entries, strings and binaries: +that's the KDBX vernacular. A small amount of metadata (timestamps, etc.) is associated with each entry, group +and the database as a whole. + +You can think of a KDBX database kind of like a file system, where groups are directories, entries are files, +and strings and binaries make up a file's contents. + +Databases are typically persisted as a encrypted, compressed files. They are usually accessed directly (i.e. +not over a network). The primary focus of this type of database is data security. It is ideal for storing +relatively small amounts of data (strings and binaries) that must remain secret except to such individuals as +have the correct I<master key>. Even if the database file were to be "leaked" to the public Internet, it +should be virtually impossible to crack with a strong key. See L</SECURITY> for an overview of security +considerations. + +=head1 RECIPES + +=head2 Create a new database + + my $kdbx = File::KDBX->new; + + my $group = $kdbx->add_group(name => 'Passwords); + my $entry = $group->add_entry( + title => 'WayneCorp', + username => 'bwayne', + password => 'iambatman', + url => 'https://example.com/login' + ); + $entry->add_auto_type_window_association('WayneCorp - Mozilla Firefox', '{PASSWORD}{ENTER}'); + + $kdbx->dump_file('mypasswords.kdbx', 'master password CHANGEME'); + +=head2 Read an existing database + + my $kdbx = File::KDBX->load_file('mypasswords.kdbx', 'master password CHANGEME'); + $kdbx->unlock; + + for my $entry (@{ $kdbx->all_entries }) { + say 'Found password for ', $entry->title, ':'; + say ' Username: ', $entry->username; + say ' Password: ', $entry->password; + } + +=head2 Search for entries + + my @entries = $kdbx->find_entries({ + title => 'WayneCorp', + }, search => 1); + +See L</QUERY> for many more query examples. + +=head2 Search for entries by auto-type window association + + my @entry_key_sequences = $kdbx->find_entries_for_window('WayneCorp - Mozilla Firefox'); + for my $pair (@entry_key_sequences) { + my ($entry, $key_sequence) = @$pair; + say 'Entry title: ', $entry->title, ', key sequence: ', $key_sequence; + } + +Example output: + + Entry title: WayneCorp, key sequence: {PASSWORD}{ENTER} + +=head1 SECURITY + +One of the biggest threats to your database security is how easily the encryption key can be brute-forced. +Strong brute-force protection depends on a couple factors: + +=for :list +* Using unguessable passwords, passphrases and key files. +* Using a brute-force resistent key derivation function. + +The first factor is up to you. This module does not enforce strong master keys. It is up to you to pick or +generate strong keys. + +The KDBX format allows for the key derivation function to be tuned. The idea is that you want each single +brute-foce attempt to be expensive (in terms of time, CPU usage or memory usage), so that making a lot of +attempts (which would be required if you have a strong master key) gets I<really> expensive. + +How expensive you want to make each attempt is up to you and can depend on the application. + +This and other KDBX-related security issues are covered here more in depth: +L<https://keepass.info/help/base/security.html> + +Here are other security risks you should be thinking about: + +=head2 Cryptography + +This distribution uses the excellent L<CryptX> and L<Crypt::Argon2> packages to handle all crypto-related +functions. As such, a lot of the security depends on the quality of these dependencies. Fortunately these +modules are maintained and appear to have good track records. + +The KDBX format has evolved over time to incorporate improved security practices and cryptographic functions. +This package uses the following functions for authentication, hashing, encryption and random number +generation: + +=for :list +* AES-128 (legacy) +* AES-256 +* Argon2d & Argon2id +* CBC block mode +* HMAC-SHA256 +* SHA256 +* SHA512 +* Salsa20 & ChaCha20 +* Twofish + +At the time of this writing, I am not aware of any successful attacks against any of these functions. These +are among the most-analyzed and widely-adopted crypto functions available. + +The KDBX format allows the body cipher and key derivation function to be configured. If a flaw is discovered +in one of these functions, you can hopefully just switch to a better function without needing to update this +software. A later software release may phase out the use of any functions which are no longer secure. + +=head2 Memory Protection + +It is not a good idea to keep secret information unencrypted in system memory for longer than is needed. The +address space of your program can generally be read by a user with elevated privileges on the system. If your +system is memory-constrained or goes into a hibernation mode, the contents of your address space could be +written to a disk where it might be persisted for long time. + +There might be system-level things you can do to reduce your risk, like using swap encryption and limiting +system access to your program's address space while your program is running. + +B<File::KDBX> helps minimize (but not eliminate) risk by keeping secrets encrypted in memory until accessed +and zeroing out memory that holds secrets after they're no longer needed, but it's not a silver bullet. + +For one thing, the encryption key is stored in the same address space. If core is dumped, the encryption key +is available to be found out. But at least there is the chance that the encryption key and the encrypted +secrets won't both be paged out while memory-constrained. + +Another problem is that some perls (somewhat notoriously) copy around memory behind the scenes willy nilly, +and it's difficult know when perl makes a copy of a secret in order to be able to zero it out later. It might +be impossible. The good news is that perls with SvPV copy-on-write (enabled by default beginning with perl +5.20) are much better in this regard. With COW, it's mostly possible to know what operations will cause perl +to copy the memory of a scalar string, and the number of copies will be significantly reduced. There is a unit +test named F<t/memory-protection.t> in this distribution that can be run on POSIX systems to determine how +well B<File::KDBX> memory protection is working. + +Memory protection also depends on how your application handles secrets. If your app code is handling scalar +strings with secret information, it's up to you to make sure its memory is zeroed out when no longer needed. +L<File::KDBX::Util/erase> et al. provide some tools to help accomplish this. Or if you're not too concerned +about the risks memory protection is meant to mitigate, then maybe don't worry about it. The security policy +of B<File::KDBX> is to try hard to keep secrets protected while in memory so that your app might claim a high +level of security, in case you care about that. + +There are some memory protection strategies that B<File::KDBX> does NOT use today but could in the future: + +Many systems allow programs to mark unswappable pages. Secret information should ideally be stored in such +pages. You could potentially use L<mlockall(2)> (or equivalent for your system) in your own application to +prevent the entire address space from being swapped. + +Some systems provide special syscalls for storing secrets in memory while keeping the encryption key outside +of the program's address space, like C<CryptProtectMemory> for Windows. This could be a good option, though +unfortunately not portable. + +=head1 QUERY + +Several methods take a I<query> as an argument (e.g. L</find_entries>). A query is just a subroutine that you +can either write yourself or have generated for you based on either a simple expression or a declarative +structure. It's easier to have your query generated, so I'll cover that first. + +=head2 Simple Expression + +A simple expression is mostly compatible with the KeePass 2 implementation +L<described here|https://keepass.info/help/base/search.html#mode_se>. + +An expression is a string with one or more space-separated terms. Terms with spaces can be enclosed in double +quotes. Terms are negated if they are prefixed with a minus sign. A record must match every term on at least +one of the given fields. + +So a simple expression is something like what you might type into a search engine. You can generate a simple +expression query using L<File::KDBX::Util/simple_expression_query> or by passing the simple expression as +a B<string reference> to search methods like L</find_entries>. + +To search for all entries in a database with the word "canyon" appearing anywhere in the title: + + my @entries = $kdbx->find_entries([ \'canyon', qw(title) ]); + +Notice the first argument is a B<stringref>. This diambiguates a simple expression from other types of queries +covered below. + +As mentioned, a simple expression can have multiple terms. This simple expression query matches any entry that +has the words "red" B<and> "canyon" anywhere in the title: + + my @entries = $kdbx->find_entries([ \'red canyon', qw(title) ]); + +Each term in the simple expression must be found for an entry to match. + +To search for entries with "red" in the title but B<not> "canyon", just prepend "canyon" with a minus sign: + + my @entries = $kdbx->find_entries([ \'red -canyon', qw(title) ]); + +To search over multiple fields simultaneously, just list them. To search for entries with "grocery" in the +title or notes but not "Foodland": + + my @entries = $kdbx->find_entries([ \'grocery -Foodland', qw(title notes) ]); + +The default operator is a case-insensitive regexp match, which is fine for searching text loosely. You can use +just about any binary comparison operator that perl supports. To specify an operator, list it after the simple +expression. For example, to search for any entry that has been used at least five times: + + my @entries = $kdbx->find_entries([ \5, '>=', qw(usage_count) ]); + +It helps to read it right-to-left, like "usage_count is >= 5". + +If you find the disambiguating structures to be confusing, you can also the L</find_entries_simple> method as +a more intuitive alternative. The following example is equivalent to the previous: + + my @entries = $kdbx->find_entries_simple(5, '>=', qw(usage_count)); + +=head2 Declarative Query + +Structuring a declarative query is similar to L<SQL::Abstract/"WHERE CLAUSES">, but you don't have to be +familiar with that module. Just learn by examples. + +To search for all entries in a database titled "My Bank": + + my @entries = $kdbx->find_entries({ title => 'My Bank' }); + +The query here is C<< { title => 'My Bank' } >>. A hashref can contain key-value pairs where the key is +a attribute of the thing being searched for (in this case an entry) and the value is what you want the thing's +attribute to be to consider it a match. In this case, the attribute we're using as our match criteria is +L<File::KDBX::Entry/title>, a text field. If an entry has its title attribute equal to "My Bank", it's +a match. + +A hashref can contain multiple attributes. The search candidate will be a match if I<all> of the specified +attributes are equal to their respective values. For example, to search for all entries with a particular URL +B<AND> username: + + my @entries = $kdbx->find_entries({ + url => 'https://example.com', + username => 'neo', + }); + +To search for entries matching I<any> criteria, just change the hashref to an arrayref. To search for entries +with a particular URL B<OR> a particular username: + + my @entries = $kdbx->find_entries([ # <-- square bracket + url => 'https://example.com', + username => 'neo', + ]); + +You can user different operators to test different types of attributes. The L<File::KDBX::Entry/icon_id> +attribute is a number, so we should use a number comparison operator. To find entries using the smartphone +icon: + + my @entries = $kdbx->find_entries({ + icon_id => { '==', ICON_SMARTPHONE }, + }); + +Note: L<File::KDBX::Constants/ICON_SMARTPHONE> is just a constant from L<File::KDBX::Constants>. It isn't +special to this example or to queries generally. We could have just used a literal number. + +The important thing to notice here is how we wrapped the condition in another arrayref with a single key-pair +where the key is the name of an operator and the value is the thing to match against. The supported operators +are: + +=for :list +* C<eq> - String equal +* C<ne> - String not equal +* C<lt> - String less than +* C<gt> - String greater than +* C<le> - String less than or equal +* C<ge> - String greater than or equal +* C<==> - Number equal +* C<!=> - Number not equal +* C<< < >> - Number less than +* C<< > >>> - Number greater than +* C<< <= >> - Number less than or equal +* C<< >= >> - Number less than or equal +* C<=~> - String match regular expression +* C<!~> - String does not match regular expression +* C<!> - Boolean false +* C<!!> - Boolean true + +Other special operators: + +=for :list +* C<-true> - Boolean true +* C<-false> - Boolean false +* C<-not> - Boolean false (alias for C<-false>) +* C<-defined> - Is defined +* C<-undef> - Is not d efined +* C<-empty> - Is empty +* C<-nonempty> - Is not empty +* C<-or> - Logical or +* C<-and> - Logical and + +Let's see another example using an explicit operator. To find all groups except one in particular (identified +by its L<File::KDBX::Group/uuid>), we can use the C<ne> (string not equal) operator: + + my ($group, @other) = $kdbx->find_groups({ + uuid => { + 'ne' => uuid('596f7520-6172-6520-7370-656369616c2e'), + }, + }); + if (@other) { say "Problem: there can be only one!" } + +Note: L<File::KDBX::Util/uuid> is a little helper function to convert a UUID in its pretty form into octets. +This helper function isn't special to this example or to queries generally. It could have been written with +a literal such as C<"\x59\x6f\x75\x20\x61...">, but that's harder to read. + +Notice we searched for groups this time. Finding groups works exactly the same as it does for entries. + +Testing the truthiness of an attribute is a little bit different because it isn't a binary operation. To find +all entries with the password quality check disabled: + + my @entries = $kdbx->find_entries({ '!' => 'quality_check' }); + +This time the string after the operator is the attribute name rather than a value to compare the attribute +against. To test that a boolean value is true, use the C<!!> operator (or C<-true> if C<!!> seems a little too +weird for your taste): + + my @entries = $kdbx->find_entries({ '!!' => 'quality_check' }); + my @entries = $kdbx->find_entries({ -true => 'quality_check' }); + +Yes, there is also a C<-false> and a C<-not> if you prefer one of those over C<!>. C<-false> and C<-not> +(along with C<-true>) are also special in that you can use them to invert the logic of a subquery. These are +logically equivalent: + + my @entries = $kdbx->find_entries([ -not => { title => 'My Bank' } ]); + my @entries = $kdbx->find_entries({ title => { 'ne' => 'My Bank' } }); + +These special operators become more useful when combined with two more special operators: C<-and> and C<-or>. +With these, it is possible to construct more interesting queries with groups of logic. For example: + + my @entries = $kdbx->find_entries({ + title => { '=~', qr/bank/ }, + -not => { + -or => { + notes => { '=~', qr/business/ }, + icon_id => { '==', ICON_TRASHCAN_FULL }, + }, + }, + }); + +In English, find entries where the word "bank" appears anywhere in the title but also do not have either the +word "business" in the notes or is using the full trashcan icon. + +=head2 Subroutine Query + +Lastly, as mentioned at the top, you can ignore all this and write your own subroutine. Your subroutine will +be called once for each thing being searched over. The single argument is the search candidate. The subroutine +should match the candidate against whatever criteria you want and return true if it matches. The C<find_*> +methods collect all matching things and return them. + +For example, to find all entries in the database titled "My Bank": + + my @entries = $kdbx->find_entries(sub { shift->title eq 'My Bank' }); + # logically the same as this declarative structure: + my @entries = $kdbx->find_entries({ title => 'My Bank' }); + # as well as this simple expression: + my @entries = $kdbx->find_entries([ \'My Bank', 'eq', qw{title} ]); + +This is a trivial example, but of course your subroutine can be arbitrarily complex. + +All of these query mechanisms described in this section are just tools, each with its own set of limitations. +If the tools are getting in your way, you can of course iterate over the contents of a database and implement +your own query logic, like this: + + for my $entry (@{ $kdbx->all_entries }) { + if (wanted($entry)) { + do_something($entry); + } + else { + ... + } + } + +=head1 ERRORS + +Errors in this package are constructed as L<File::KDBX::Error> objects and propagated using perl's built-in +mechanisms. Fatal errors are propagated using L<functions/die> and non-fatal errors (a.k.a. warnings) are +propagated using L<functions/warn> while adhering to perl's L<warnings> system. If you're already familiar +with these mechanisms, you can skip this section. + +You can catch fatal errors using L<functions/eval> (or something like L<Try::Tiny>) and non-fatal errors using +C<$SIG{__WARN__}> (see L<variables/%SIG>). Examples: + + use File::KDBX::Error qw(error); + + my $key = ''; # uh oh + eval { + $kdbx->load_file('whatever.kdbx', $key); + }; + if (my $error = error($@)) { + handle_missing_key($error) if $error->type eq 'key.missing'; + $error->throw; + } + +or using C<Try::Tiny>: + + try { + $kdbx->load_file('whatever.kdbx', $key); + } + catch { + handle_error($_); + }; + +Catching non-fatal errors: + + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, $_[0] }; + + $kdbx->load_file('whatever.kdbx', $key); + + handle_warnings(@warnings) if @warnings; + +By default perl prints warnings to C<STDERR> if you don't catch them. If you don't want to catch them and also +don't want them printed to C<STDERR>, you can suppress them lexically (perl v5.28 or higher required): + + { + no warnings 'File::KDBX'; + ... + } + +or locally: + + { + local $File::KDBX::WARNINGS = 0; + ... + } + +or globally in your program: + + $File::KDBX::WARNINGS = 0; + +You cannot suppress fatal errors, and if you don't catch them your program will exit. + +=head1 ENVIRONMENT + +This software will alter its behavior depending on the value of certain environment variables: + +=for :list +* C<PERL_FILE_KDBX_XS> - Do not use L<File::KDBX::XS> if false (default: true) +* C<PERL_ONLY> - Do not use L<File::KDBX::XS> if true (default: false) +* C<NO_FORK> - Do not fork if true (default: false) + +=head1 CAVEATS + +Some features (e.g. parsing) require 64-bit perl. It should be possible and actually pretty easy to make it +work using L<Math::BigInt>, but I need to build a 32-bit perl in order to test it and frankly I'm still +figuring out how. I'm sure it's simple so I'll mark this one "TODO", but for now an exception will be thrown +when trying to use such features with undersized IVs. + +=head1 SEE ALSO + +L<File::KeePass> is a much older alternative. It's good but has a backlog of bugs and lacks support for newer +KDBX features. + +=cut diff --git a/lib/File/KDBX/Cipher.pm b/lib/File/KDBX/Cipher.pm new file mode 100644 index 0000000..5c1f120 --- /dev/null +++ b/lib/File/KDBX/Cipher.pm @@ -0,0 +1,344 @@ +package File::KDBX::Cipher; +# ABSTRACT: A block cipher mode or cipher stream + +use warnings; +use strict; + +use Devel::GlobalDestruction; +use File::KDBX::Constants qw(:cipher :random_stream); +use File::KDBX::Error; +use File::KDBX::Util qw(erase format_uuid); +use Module::Load; +use Scalar::Util qw(looks_like_number); +use namespace::clean; + +our $VERSION = '999.999'; # VERSION + +my %CIPHERS; + +=method new + +=method new_from_uuid + +=method new_from_stream_id + + $cipher = File::KDBX::Cipher->new(uuid => $uuid, key => $key, iv => $iv); + # OR + $cipher = File::KDBX::Cipher->new_from_uuid($uuid, key => $key, iv => $iv); + + $cipher = File::KDBX::Cipher->new(stream_id => $id, key => $key); + # OR + $cipher = File::KDBX::Cipher->new_from_stream_id($id, key => $key); + +Construct a new L<File::KDBX::Cipher>. + +This is a factory method which returns a subclass. + +=cut + +sub new { + my $class = shift; + my %args = @_; + + return $class->new_from_uuid(delete $args{uuid}, %args) if defined $args{uuid}; + return $class->new_from_stream_id(delete $args{stream_id}, %args) if defined $args{stream_id}; + + throw 'Must pass uuid or stream_id'; +} + +sub new_from_uuid { + my $class = shift; + my $uuid = shift; + my %args = @_; + + $args{key} or throw 'Missing encryption key'; + $args{iv} or throw 'Missing encryption IV'; + + my $formatted_uuid = format_uuid($uuid); + + my $cipher = $CIPHERS{$uuid} or throw "Unsupported cipher ($formatted_uuid)", uuid => $uuid; + ($class, my %registration_args) = @$cipher; + + my @args = (%args, %registration_args, uuid => $uuid); + load $class; + my $self = bless {@args}, $class; + return $self->init(@args); +} + +sub new_from_stream_id { + my $class = shift; + my $id = shift; + my %args = @_; + + $args{key} or throw 'Missing encryption key'; + + my $cipher = $CIPHERS{$id} or throw "Unsupported stream cipher ($id)", id => $id; + ($class, my %registration_args) = @$cipher; + + my @args = (%args, %registration_args, stream_id => $id); + load $class; + my $self = bless {@args}, $class; + return $self->init(@args); +} + +=method init + + $self->init; + +Initialize the cipher. Called by </new>. + +=cut + +sub init { $_[0] } + +sub DESTROY { !in_global_destruction and erase \$_[0]->{key} } + +=attr uuid + + $uuid = $cipher->uuid; + +Get the UUID if the cipher was constructed with one. + +=cut + +sub uuid { $_[0]->{uuid} } + +=attr stream_id + + $stream_id = $cipher->stream_id; + +Get the stream ID if the cipher was constructed with one. + +=cut + +sub stream_id { $_[0]->{stream_id} } + +=attr key + + $key = $cipher->key; + +Get the raw encryption key. + +=cut + +sub key { $_[0]->{key} } + +=attr iv + + $iv = $cipher->iv; + +Get the initialization vector. + +=cut + +sub iv { $_[0]->{iv} } + +=attr default_iv_size + + $size = $cipher->default_iv_size; + +Get the default size of the initialization vector, in bytes. + +=cut + +sub key_size { -1 } + +=attr key_size + + $size = $cipher->key_size; + +Get the size the mode expects the key to be, in bytes. + +=cut + +sub iv_size { 0 } + +=attr block_size + + $size = $cipher->block_size; + +Get the block size, in bytes. + +=cut + +sub block_size { 0 } + +=method encrypt + + $ciphertext = $cipher->encrypt($plaintext, ...); + +Encrypt some data. + +=cut + +sub encrypt { die "Not implemented" } + +=method decrypt + + $plaintext = $cipher->decrypt($ciphertext, ...); + +Decrypt some data. + +=cut + +sub decrypt { die "Not implemented" } + +=method finish + + $ciphertext .= $cipher->finish; # if encrypting + $plaintext .= $cipher->finish; # if decrypting + +Finish the stream. + +=cut + +sub finish { '' } + +=method encrypt_finish + + $ciphertext = $cipher->encrypt_finish($plaintext, ...); + +Encrypt and finish a stream in one call. + +=cut + +sub encrypt_finish { + my $self = shift; + my $out = $self->encrypt(@_); + $out .= $self->finish; + return $out; +} + +=method decrypt_finish + + $plaintext = $cipher->decrypt_finish($ciphertext, ...); + +Decrypt and finish a stream in one call. + +=cut + +sub decrypt_finish { + my $self = shift; + my $out = $self->decrypt(@_); + $out .= $self->finish; + return $out; +} + +=method register + + File::KDBX::Cipher->register($uuid => $package, %args); + +Register a cipher. Registered ciphers can be used to encrypt and decrypt KDBX databases. A cipher's UUID +B<must> be unique and B<musn't change>. A cipher UUID is written into each KDBX file and the associated cipher +must be registered with the same UUID in order to decrypt the KDBX file. + +C<$package> should be a Perl package relative to C<File::KDBX::Cipher::> or prefixed with a C<+> if it is +a fully-qualified package. C<%args> are passed as-is to the cipher's L</init> method. + +=cut + +sub register { + my $class = shift; + my $id = shift; + my $package = shift; + my @args = @_; + + my $formatted_id = looks_like_number($id) ? $id : format_uuid($id); + $package = "${class}::${package}" if $package !~ s/^\+// && $package !~ /^\Q${class}::\E/; + + my %blacklist = map { (looks_like_number($_) ? $_ : File::KDBX::Util::uuid($_)) => 1 } + split(/,/, $ENV{FILE_KDBX_CIPHER_BLACKLIST} // ''); + if ($blacklist{$id} || $blacklist{$package}) { + alert "Ignoring blacklisted cipher ($formatted_id)", id => $id, package => $package; + return; + } + + if (defined $CIPHERS{$id}) { + alert "Overriding already-registered cipher ($formatted_id) with package $package", + id => $id, + package => $package; + } + + $CIPHERS{$id} = [$package, @args]; +} + +=method unregister + + File::KDBX::Cipher->unregister($uuid); + +Unregister a cipher. Unregistered ciphers can no longer be used to encrypt and decrypt KDBX databases, until +reregistered (see L</register>). + +=cut + +sub unregister { + delete $CIPHERS{$_} for @_; +} + +BEGIN { + __PACKAGE__->register(CIPHER_UUID_AES128, 'CBC', algorithm => 'AES', key_size => 16); + __PACKAGE__->register(CIPHER_UUID_AES256, 'CBC', algorithm => 'AES', key_size => 32); + __PACKAGE__->register(CIPHER_UUID_SERPENT, 'CBC', algorithm => 'Serpent', key_size => 32); + __PACKAGE__->register(CIPHER_UUID_TWOFISH, 'CBC', algorithm => 'Twofish', key_size => 32); + __PACKAGE__->register(CIPHER_UUID_CHACHA20, 'Stream', algorithm => 'ChaCha'); + __PACKAGE__->register(CIPHER_UUID_SALSA20, 'Stream', algorithm => 'Salsa20'); + __PACKAGE__->register(STREAM_ID_CHACHA20, 'Stream', algorithm => 'ChaCha'); + __PACKAGE__->register(STREAM_ID_SALSA20, 'Stream', algorithm => 'Salsa20'); +} + +1; +__END__ + +=head1 SYNOPSIS + + use File::KDBX::Cipher; + + my $cipher = File::KDBX::Cipher->new(uuid => $uuid, key => $key, iv => $iv); + + my $ciphertext = $cipher->encrypt('data'); + $ciphertext .= $cipher->encrypt('more data'); + $ciphertext .= $cipher->finish; + + my $plaintext = $cipher->decrypt('data'); + $plaintext .= $cipher->decrypt('more data'); + $plaintext .= $cipher->finish; + +=head1 DESCRIPTION + +A cipher is used to encrypt and decrypt KDBX files. The L<File::KDBX> distribution comes with several +pre-registered ciphers ready to go: + +=for :list +* C<61AB05A1-9464-41C3-8D74-3A563DF8DD35> - AES128 (legacy) +* C<31C1F2E6-BF71-4350-BE58-05216AFC5AFF> - AES256 +* C<D6038A2B-8B6F-4CB5-A524-339A31DBB59A> - ChaCha20 +* C<716E1C8A-EE17-4BDC-93AE-A977B882833A> - Salsa20 +* C<098563FF-DDF7-4F98-8619-8079F6DB897A> - Serpent +* C<AD68F29F-576F-4BB9-A36A-D47AF965346C> - Twofish + +B<NOTE:> If you want your KDBX file to be readable by other KeePass implementations, you must use a UUID and +algorithm that they support. From the list above, AES256 and ChaCha20 are well-supported. You should avoid +AES128 for new databases. + +You can also L</register> your own cipher. Here is a skeleton: + + package File::KDBX::Cipher::MyCipher; + + use parent 'File::KDBX::Cipher'; + + File::KDBX::Cipher->register( + # $uuid, $package, %args + "\x12\x34\x56\x78\x9a\xbc\xde\xfg\x12\x34\x56\x78\x9a\xbc\xde\xfg" => __PACKAGE__, + ); + + sub init { ... } # optional + + sub encrypt { ... } + sub decrypt { ... } + sub finish { ... } + + sub key_size { ... } + sub iv_size { ... } + sub block_size { ... } + +=cut diff --git a/lib/File/KDBX/Cipher/CBC.pm b/lib/File/KDBX/Cipher/CBC.pm new file mode 100644 index 0000000..8336af4 --- /dev/null +++ b/lib/File/KDBX/Cipher/CBC.pm @@ -0,0 +1,71 @@ +package File::KDBX::Cipher::CBC; +# ABSTRACT: A CBC block cipher mode encrypter/decrypter + +use warnings; +use strict; + +use Crypt::Mode::CBC; +use File::KDBX::Error; +use namespace::clean; + +use parent 'File::KDBX::Cipher'; + +our $VERSION = '999.999'; # VERSION + +sub encrypt { + my $self = shift; + + my $mode = $self->{mode} ||= do { + my $m = Crypt::Mode::CBC->new($self->algorithm); + $m->start_encrypt($self->key, $self->iv); + $m; + }; + + return join('', map { $mode->add(ref $_ ? $$_ : $_) } grep { defined } @_); +} + +sub decrypt { + my $self = shift; + + my $mode = $self->{mode} ||= do { + my $m = Crypt::Mode::CBC->new($self->algorithm); + $m->start_decrypt($self->key, $self->iv); + $m; + }; + + return join('', map { $mode->add(ref $_ ? $$_ : $_) } grep { defined } @_); +} + +sub finish { + my $self = shift; + return '' if !$self->{mode}; + my $out = $self->{mode}->finish; + delete $self->{mode}; + return $out; +} + +=attr algorithm + +Get the symmetric cipher algorithm. + +=cut + +sub algorithm { $_[0]->{algorithm} or throw 'Block cipher algorithm is not set' } +sub key_size { $_[0]->{key_size} // 32 } +sub iv_size { 16 } +sub block_size { 16 } + +1; +__END__ + +=head1 SYNOPSIS + + use File::KDBX::Cipher::CBC; + + my $cipher = File::KDBX::Cipher::CBC->new(algorithm => $algo, key => $key, iv => $iv); + +=head1 DESCRIPTION + +A subclass of L<File::KDBX::Cipher> for encrypting and decrypting data using the CBC block cipher mode. + +=cut diff --git a/lib/File/KDBX/Cipher/Stream.pm b/lib/File/KDBX/Cipher/Stream.pm new file mode 100644 index 0000000..1b9aeca --- /dev/null +++ b/lib/File/KDBX/Cipher/Stream.pm @@ -0,0 +1,131 @@ +package File::KDBX::Cipher::Stream; +# ABSTRACT: A cipher stream encrypter/decrypter + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use File::KDBX::Constants qw(:cipher :random_stream); +use File::KDBX::Error; +use Module::Load; +use namespace::clean; + +use parent 'File::KDBX::Cipher'; + +our $VERSION = '999.999'; # VERSION + +sub init { + my $self = shift; + my %args = @_; + + if (my $uuid = $args{uuid}) { + if ($uuid eq CIPHER_UUID_CHACHA20 && length($args{iv}) == 16) { + # extract the counter + my $buf = substr($self->{iv}, 0, 4, ''); + $self->{counter} = unpack('L<', $buf); + } + elsif ($uuid eq CIPHER_UUID_SALSA20) { + # only need eight bytes... + $self->{iv} = substr($args{iv}, 8); + } + } + elsif (my $id = $args{stream_id}) { + my $key_ref = ref $args{key} ? $args{key} : \$args{key}; + if ($id == STREAM_ID_CHACHA20) { + ($self->{key}, $self->{iv}) = unpack('a32 a12', digest_data('SHA512', $$key_ref)); + } + elsif ($id == STREAM_ID_SALSA20) { + ($self->{key}, $self->{iv}) = (digest_data('SHA256', $$key_ref), STREAM_SALSA20_IV); + } + } + + return $self; +} + +sub crypt { + my $self = shift; + my $stream = $self->_stream; + return join('', map { $stream->crypt(ref $_ ? $$_ : $_) } grep { defined } @_); +} + +sub keystream { + my $self = shift; + return $self->_stream->keystream(@_); +} + +sub dup { + my $self = shift; + my $dup = File::KDBX::Cipher->new( + stream_id => $self->stream_id, + key => $self->key, + @_, + ); + $dup->{key} = $self->key; + $dup->{iv} = $self->iv; + # FIXME - probably turn this into a proper clone method + return $dup; +} + +sub _stream { + my $self = shift; + + $self->{stream} //= do { + my $s = eval { + my $pkg = 'Crypt::Stream::'.$self->algorithm; + my $counter = $self->counter; + my $pos = 0; + if (defined (my $offset = $self->offset)) { + $counter = int($offset / 64); + $pos = $offset % 64; + } + my $s = $pkg->new($self->key, $self->iv, $counter); + # seek to correct position within block + $s->keystream($pos) if $pos; + $s; + }; + if (my $err = $@) { + throw 'Failed to initialize stream cipher library', + error => $err, + algorithm => $self->algorithm, + key_length => length($self->key), + iv_length => length($self->iv), + iv => unpack('H*', $self->iv), + key => unpack('H*', $self->key); + } + $s; + }; +} + +sub encrypt { goto &crypt } +sub decrypt { goto &crypt } + +sub finish { delete $_[0]->{stream}; '' } + +sub counter { $_[0]->{counter} // 0 } +sub offset { $_[0]->{offset} } + +=attr algorithm + +Get the stream cipher algorithm. Can be one of C<Salsa20> and C<ChaCha>. + +=cut + +sub algorithm { $_[0]->{algorithm} or throw 'Stream cipher algorithm is not set' } +sub key_size { { Salsa20 => 32, ChaCha => 32 }->{$_[0]->{algorithm} || ''} // 0 } +sub iv_size { { Salsa20 => 8, ChaCha => 12 }->{$_[0]->{algorithm} || ''} // -1 } +sub block_size { 1 } + +1; +__END__ + +=head1 SYNOPSIS + + use File::KDBX::Cipher::Stream; + + my $cipher = File::KDBX::Cipher::Stream->new(algorithm => $algorithm, key => $key, iv => $iv); + +=head1 DESCRIPTION + +A subclass of L<File::KDBX::Cipher> for encrypting and decrypting data using a stream cipher. + +=cut diff --git a/lib/File/KDBX/Constants.pm b/lib/File/KDBX/Constants.pm new file mode 100644 index 0000000..be17f76 --- /dev/null +++ b/lib/File/KDBX/Constants.pm @@ -0,0 +1,610 @@ +package File::KDBX::Constants; +# ABSTRACT: All the KDBX-related constants you could ever want + +# HOW TO add new constants: +# 1. Add it to the %CONSTANTS structure below. +# 2. List it in the pod at the bottom of this file in the section corresponding to its tag. +# 3. There is no step three. + +use warnings; +use strict; + +use Exporter qw(import); +use Scalar::Util qw(dualvar); +use namespace::clean -except => 'import'; + +our $VERSION = '999.999'; # VERSION + +BEGIN { + my %CONSTANTS = ( + magic => { + __prefix => 'KDBX', + SIG1 => 0x9aa2d903, + SIG1_FIRST_BYTE => 0x03, + SIG2_1 => 0xb54bfb65, + SIG2_2 => 0xb54bfb67, + }, + version => { + __prefix => 'KDBX_VERSION', + _2_0 => 0x00020000, + _3_0 => 0x00030000, + _3_1 => 0x00030001, + _4_0 => 0x00040000, + _4_1 => 0x00040001, + OLDEST => 0x00020000, + LATEST => 0x00040001, + MAJOR_MASK => 0xffff0000, + MINOR_MASK => 0x0000ffff, + }, + header => { + __prefix => 'HEADER', + END => dualvar( 0, 'end'), + COMMENT => dualvar( 1, 'comment'), + CIPHER_ID => dualvar( 2, 'cipher_id'), + COMPRESSION_FLAGS => dualvar( 3, 'compression_flags'), + MASTER_SEED => dualvar( 4, 'master_seed'), + TRANSFORM_SEED => dualvar( 5, 'transform_seed'), + TRANSFORM_ROUNDS => dualvar( 6, 'transform_rounds'), + ENCRYPTION_IV => dualvar( 7, 'encryption_iv'), + INNER_RANDOM_STREAM_KEY => dualvar( 8, 'inner_random_stream_key'), + STREAM_START_BYTES => dualvar( 9, 'stream_start_bytes'), + INNER_RANDOM_STREAM_ID => dualvar( 10, 'inner_random_stream_id'), + KDF_PARAMETERS => dualvar( 11, 'kdf_parameters'), + PUBLIC_CUSTOM_DATA => dualvar( 12, 'public_custom_data'), + }, + compression => { + __prefix => 'COMPRESSION', + NONE => dualvar( 0, 'none'), + GZIP => dualvar( 1, 'gzip'), + }, + cipher => { + __prefix => 'CIPHER', + UUID_AES128 => "\x61\xab\x05\xa1\x94\x64\x41\xc3\x8d\x74\x3a\x56\x3d\xf8\xdd\x35", + UUID_AES256 => "\x31\xc1\xf2\xe6\xbf\x71\x43\x50\xbe\x58\x05\x21\x6a\xfc\x5a\xff", + UUID_CHACHA20 => "\xd6\x03\x8a\x2b\x8b\x6f\x4c\xb5\xa5\x24\x33\x9a\x31\xdb\xb5\x9a", + UUID_SALSA20 => "\x71\x6e\x1c\x8a\xee\x17\x4b\xdc\x93\xae\xa9\x77\xb8\x82\x83\x3a", + UUID_SERPENT => "\x09\x85\x63\xff\xdd\xf7\x4f\x98\x86\x19\x80\x79\xf6\xdb\x89\x7a", + UUID_TWOFISH => "\xad\x68\xf2\x9f\x57\x6f\x4b\xb9\xa3\x6a\xd4\x7a\xf9\x65\x34\x6c", + }, + kdf => { + __prefix => 'KDF', + UUID_AES => "\xc9\xd9\xf3\x9a\x62\x8a\x44\x60\xbf\x74\x0d\x08\xc1\x8a\x4f\xea", + UUID_AES_CHALLENGE_RESPONSE => "\x7c\x02\xbb\x82\x79\xa7\x4a\xc0\x92\x7d\x11\x4a\x00\x64\x82\x38", + UUID_ARGON2D => "\xef\x63\x6d\xdf\x8c\x29\x44\x4b\x91\xf7\xa9\xa4\x03\xe3\x0a\x0c", + UUID_ARGON2ID => "\x9e\x29\x8b\x19\x56\xdb\x47\x73\xb2\x3d\xfc\x3e\xc6\xf0\xa1\xe6", + PARAM_UUID => '$UUID', + PARAM_AES_ROUNDS => 'R', + PARAM_AES_SEED => 'S', + PARAM_ARGON2_SALT => 'S', + PARAM_ARGON2_PARALLELISM => 'P', + PARAM_ARGON2_MEMORY => 'M', + PARAM_ARGON2_ITERATIONS => 'I', + PARAM_ARGON2_VERSION => 'V', + PARAM_ARGON2_SECRET => 'K', + PARAM_ARGON2_ASSOCDATA => 'A', + DEFAULT_AES_ROUNDS => 100_000, + DEFAULT_ARGON2_ITERATIONS => 10, + DEFAULT_ARGON2_MEMORY => 1 << 16, + DEFAULT_ARGON2_PARALLELISM => 2, + DEFAULT_ARGON2_VERSION => 0x13, + }, + random_stream => { + __prefix => 'STREAM', + ID_RC4_VARIANT => 1, + ID_SALSA20 => 2, + ID_CHACHA20 => 3, + SALSA20_IV => "\xe8\x30\x09\x4b\x97\x20\x5d\x2a", + + }, + variant_map => { + __prefix => 'VMAP', + VERSION => 0x0100, + VERSION_MAJOR_MASK => 0xff00, + TYPE_END => 0x00, + TYPE_UINT32 => 0x04, + TYPE_UINT64 => 0x05, + TYPE_BOOL => 0x08, + TYPE_INT32 => 0x0C, + TYPE_INT64 => 0x0D, + TYPE_STRING => 0x18, + TYPE_BYTEARRAY => 0x42, + }, + inner_header => { + __prefix => 'INNER_HEADER', + END => dualvar( 0, 'end'), + INNER_RANDOM_STREAM_ID => dualvar( 1, 'inner_random_stream_id'), + INNER_RANDOM_STREAM_KEY => dualvar( 2, 'inner_random_stream_key'), + BINARY => dualvar( 3, 'binary'), + BINARY_FLAG_PROTECT => 1, + }, + key_file => { + __prefix => 'KEY_FILE', + TYPE_BINARY => dualvar( 1, 'binary'), + TYPE_HASHED => dualvar( 3, 'hashed'), + TYPE_HEX => dualvar( 2, 'hex'), + TYPE_XML => dualvar( 4, 'xml'), + }, + history => { + __prefix => 'HISTORY', + DEFAULT_MAX_ITEMS => 10, + DEFAULT_MAX_SIZE => 6_291_456, # 6 M + }, + icon => { + __prefix => 'ICON', + PASSWORD => dualvar( 0, 'Password'), + PACKAGE_NETWORK => dualvar( 1, 'Package_Network'), + MESSAGEBOX_WARNING => dualvar( 2, 'MessageBox_Warning'), + SERVER => dualvar( 3, 'Server'), + KLIPPER => dualvar( 4, 'Klipper'), + EDU_LANGUAGES => dualvar( 5, 'Edu_Languages'), + KCMDF => dualvar( 6, 'KCMDF'), + KATE => dualvar( 7, 'Kate'), + SOCKET => dualvar( 8, 'Socket'), + IDENTITY => dualvar( 9, 'Identity'), + KONTACT => dualvar( 10, 'Kontact'), + CAMERA => dualvar( 11, 'Camera'), + IRKICKFLASH => dualvar( 12, 'IRKickFlash'), + KGPG_KEY3 => dualvar( 13, 'KGPG_Key3'), + LAPTOP_POWER => dualvar( 14, 'Laptop_Power'), + SCANNER => dualvar( 15, 'Scanner'), + MOZILLA_FIREBIRD => dualvar( 16, 'Mozilla_Firebird'), + CDROM_UNMOUNT => dualvar( 17, 'CDROM_Unmount'), + DISPLAY => dualvar( 18, 'Display'), + MAIL_GENERIC => dualvar( 19, 'Mail_Generic'), + MISC => dualvar( 20, 'Misc'), + KORGANIZER => dualvar( 21, 'KOrganizer'), + ASCII => dualvar( 22, 'ASCII'), + ICONS => dualvar( 23, 'Icons'), + CONNECT_ESTABLISHED => dualvar( 24, 'Connect_Established'), + FOLDER_MAIL => dualvar( 25, 'Folder_Mail'), + FILESAVE => dualvar( 26, 'FileSave'), + NFS_UNMOUNT => dualvar( 27, 'NFS_Unmount'), + MESSAGE => dualvar( 28, 'Message'), + KGPG_TERM => dualvar( 29, 'KGPG_Term'), + KONSOLE => dualvar( 30, 'Konsole'), + FILEPRINT => dualvar( 31, 'FilePrint'), + FSVIEW => dualvar( 32, 'FSView'), + RUN => dualvar( 33, 'Run'), + CONFIGURE => dualvar( 34, 'Configure'), + KRFB => dualvar( 35, 'KRFB'), + ARK => dualvar( 36, 'Ark'), + KPERCENTAGE => dualvar( 37, 'KPercentage'), + SAMBA_UNMOUNT => dualvar( 38, 'Samba_Unmount'), + HISTORY => dualvar( 39, 'History'), + MAIL_FIND => dualvar( 40, 'Mail_Find'), + VECTORGFX => dualvar( 41, 'VectorGfx'), + KCMMEMORY => dualvar( 42, 'KCMMemory'), + TRASHCAN_FULL => dualvar( 43, 'Trashcan_Full'), + KNOTES => dualvar( 44, 'KNotes'), + CANCEL => dualvar( 45, 'Cancel'), + HELP => dualvar( 46, 'Help'), + KPACKAGE => dualvar( 47, 'KPackage'), + FOLDER => dualvar( 48, 'Folder'), + FOLDER_BLUE_OPEN => dualvar( 49, 'Folder_Blue_Open'), + FOLDER_TAR => dualvar( 50, 'Folder_Tar'), + DECRYPTED => dualvar( 51, 'Decrypted'), + ENCRYPTED => dualvar( 52, 'Encrypted'), + APPLY => dualvar( 53, 'Apply'), + SIGNATURE => dualvar( 54, 'Signature'), + THUMBNAIL => dualvar( 55, 'Thumbnail'), + KADDRESSBOOK => dualvar( 56, 'KAddressBook'), + VIEW_TEXT => dualvar( 57, 'View_Text'), + KGPG => dualvar( 58, 'KGPG'), + PACKAGE_DEVELOPMENT => dualvar( 59, 'Package_Development'), + KFM_HOME => dualvar( 60, 'KFM_Home'), + SERVICES => dualvar( 61, 'Services'), + TUX => dualvar( 62, 'Tux'), + FEATHER => dualvar( 63, 'Feather'), + APPLE => dualvar( 64, 'Apple'), + W => dualvar( 65, 'W'), + MONEY => dualvar( 66, 'Money'), + CERTIFICATE => dualvar( 67, 'Certificate'), + SMARTPHONE => dualvar( 68, 'Smartphone'), + }, + time => { + __prefix => 'TIME', + SECONDS_AD1_TO_UNIX_EPOCH => 62_135_596_800, + }, + yubikey => { + YUBICO_VID => dualvar( 0x1050, 'Yubico'), + YUBIKEY_PID => dualvar( 0x0010, 'YubiKey 1/2'), + NEO_OTP_PID => dualvar( 0x0110, 'YubiKey NEO OTP'), + NEO_OTP_CCID_PID => dualvar( 0x0111, 'YubiKey NEO OTP+CCID'), + NEO_CCID_PID => dualvar( 0x0112, 'YubiKey NEO CCID'), + NEO_U2F_PID => dualvar( 0x0113, 'YubiKey NEO FIDO'), + NEO_OTP_U2F_PID => dualvar( 0x0114, 'YubiKey NEO OTP+FIDO'), + NEO_U2F_CCID_PID => dualvar( 0x0115, 'YubiKey NEO FIDO+CCID'), + NEO_OTP_U2F_CCID_PID => dualvar( 0x0116, 'YubiKey NEO OTP+FIDO+CCID'), + YK4_OTP_PID => dualvar( 0x0401, 'YubiKey 4/5 OTP'), + YK4_U2F_PID => dualvar( 0x0402, 'YubiKey 4/5 FIDO'), + YK4_OTP_U2F_PID => dualvar( 0x0403, 'YubiKey 4/5 OTP+FIDO'), + YK4_CCID_PID => dualvar( 0x0404, 'YubiKey 4/5 CCID'), + YK4_OTP_CCID_PID => dualvar( 0x0405, 'YubiKey 4/5 OTP+CCID'), + YK4_U2F_CCID_PID => dualvar( 0x0406, 'YubiKey 4/5 FIDO+CCID'), + YK4_OTP_U2F_CCID_PID => dualvar( 0x0407, 'YubiKey 4/5 OTP+FIDO+CCID'), + PLUS_U2F_OTP_PID => dualvar( 0x0410, 'YubiKey Plus OTP+FIDO'), + + ONLYKEY_VID => dualvar( 0x1d50, 'OnlyKey'), + ONLYKEY_PID => dualvar( 0x60fc, 'OnlyKey'), + + YK_EUSBERR => dualvar( 0x01, 'USB error'), + YK_EWRONGSIZ => dualvar( 0x02, 'wrong size'), + YK_EWRITEERR => dualvar( 0x03, 'write error'), + YK_ETIMEOUT => dualvar( 0x04, 'timeout'), + YK_ENOKEY => dualvar( 0x05, 'no yubikey present'), + YK_EFIRMWARE => dualvar( 0x06, 'unsupported firmware version'), + YK_ENOMEM => dualvar( 0x07, 'out of memory'), + YK_ENOSTATUS => dualvar( 0x08, 'no status structure given'), + YK_ENOTYETIMPL => dualvar( 0x09, 'not yet implemented'), + YK_ECHECKSUM => dualvar( 0x0a, 'checksum mismatch'), + YK_EWOULDBLOCK => dualvar( 0x0b, 'operation would block'), + YK_EINVALIDCMD => dualvar( 0x0c, 'invalid command for operation'), + YK_EMORETHANONE => dualvar( 0x0d, 'expected only one YubiKey but serveral present'), + YK_ENODATA => dualvar( 0x0e, 'no data returned from device'), + + CONFIG1_VALID => 0x01, + CONFIG2_VALID => 0x02, + CONFIG1_TOUCH => 0x04, + CONFIG2_TOUCH => 0x08, + CONFIG_LED_INV => 0x10, + CONFIG_STATUS_MASK => 0x1f, + }, + ); + + our %EXPORT_TAGS; + my %seen; + no strict 'refs'; ## no critic (ProhibitNoStrict) + while (my ($tag, $constants) = each %CONSTANTS) { + my $prefix = delete $constants->{__prefix}; + while (my ($name, $value) = each %$constants) { + my $val = $value; + $val = $val+0 if $tag eq 'icon'; # TODO + $name =~ s/^_+//; + my $full_name = $prefix ? "${prefix}_${name}" : $name; + die "Duplicate constant: $full_name\n" if $seen{$full_name}; + *{$full_name} = sub() { $value }; + push @{$EXPORT_TAGS{$tag} //= []}, $full_name; + $seen{$full_name}++; + } + } +} + +our %EXPORT_TAGS; +push @{$EXPORT_TAGS{header}}, 'KDBX_HEADER'; +push @{$EXPORT_TAGS{inner_header}}, 'KDBX_INNER_HEADER'; + +$EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS]; +our @EXPORT_OK = sort @{$EXPORT_TAGS{all}}; + +my %HEADER; +for my $header ( + HEADER_END, HEADER_COMMENT, HEADER_CIPHER_ID, HEADER_COMPRESSION_FLAGS, + HEADER_MASTER_SEED, HEADER_TRANSFORM_SEED, HEADER_TRANSFORM_ROUNDS, + HEADER_ENCRYPTION_IV, HEADER_INNER_RANDOM_STREAM_KEY, HEADER_STREAM_START_BYTES, + HEADER_INNER_RANDOM_STREAM_ID, HEADER_KDF_PARAMETERS, HEADER_PUBLIC_CUSTOM_DATA, +) { + $HEADER{$header} = $HEADER{0+$header} = $header; +} +sub KDBX_HEADER { $HEADER{$_[0]} } + + +my %INNER_HEADER; +for my $inner_header ( + INNER_HEADER_END, INNER_HEADER_INNER_RANDOM_STREAM_ID, + INNER_HEADER_INNER_RANDOM_STREAM_KEY, INNER_HEADER_BINARY, +) { + $INNER_HEADER{$inner_header} = $INNER_HEADER{0+$inner_header} = $inner_header; +} +sub KDBX_INNER_HEADER { $INNER_HEADER{$_[0]} } + +1; +__END__ + +=head1 SYNOPSIS + + use File::KDBX::Constants qw(:all); + + say KDBX_VERSION_4_1; + +=head1 DESCRIPTION + +This module provides importable constants related to KDBX. Constants can be imported individually or in groups +(by tag). The available tags are: + +=for :list +* L</:magic> +* L</:version> +* L</:header> +* L</:compression> +* L</:cipher> +* L</:random_stream> +* L</:kdf> +* L</:variant_map> +* L</:inner_header> +* L</:key_file> +* L</:history> +* L</:icon> +* L</:time> +* L</:yubikey> +* C<:all> - All of the above + +View the source of this module to see the constant values (but really you shouldn't care). + +=head1 CONSTANTS + +=head2 :magic + +Constants related to identifying the file types: + +=for :list += C<KDBX_SIG1> += C<KDBX_SIG1_FIRST_BYTE> += C<KDBX_SIG2_1> += C<KDBX_SIG2_2> + +=head2 :version + +Constants related to identifying the format version of a file: + +=for :list += C<KDBX_VERSION_2_0> += C<KDBX_VERSION_3_0> += C<KDBX_VERSION_3_1> += C<KDBX_VERSION_4_0> += C<KDBX_VERSION_4_1> += C<KDBX_VERSION_OLDEST> += C<KDBX_VERSION_LATEST> += C<KDBX_VERSION_MAJOR_MASK> += C<KDBX_VERSION_MINOR_MASK> + +=head2 :header + +Constants related to parsing and generating KDBX file headers: + +=for :list += C<HEADER_END> += C<HEADER_COMMENT> += C<HEADER_CIPHER_ID> += C<HEADER_COMPRESSION_FLAGS> += C<HEADER_MASTER_SEED> += C<HEADER_TRANSFORM_SEED> += C<HEADER_TRANSFORM_ROUNDS> += C<HEADER_ENCRYPTION_IV> += C<HEADER_INNER_RANDOM_STREAM_KEY> += C<HEADER_STREAM_START_BYTES> += C<HEADER_INNER_RANDOM_STREAM_ID> += C<HEADER_KDF_PARAMETERS> += C<HEADER_PUBLIC_CUSTOM_DATA> += C<KDBX_HEADER> + +=head2 :compression + +Constants related to identifying the compression state of a file: + +=for :list += C<COMPRESSION_NONE> += C<COMPRESSION_GZIP> + +=head2 :cipher + +Constants related ciphers: + +=for :list += C<CIPHER_UUID_AES128> += C<CIPHER_UUID_AES256> += C<CIPHER_UUID_CHACHA20> += C<CIPHER_UUID_SALSA20> += C<CIPHER_UUID_SERPENT> += C<CIPHER_UUID_TWOFISH> + +=head2 :random_stream + +Constants related to memory protection stream ciphers: + +=for :list += C<STREAM_ID_RC4_VARIANT> +This is insecure and not implemented. += C<STREAM_ID_SALSA20> += C<STREAM_ID_CHACHA20> += C<STREAM_SALSA20_IV> + +=head2 :kdf + +Constants related to key derivation functions and configuration: + +=for :list += C<KDF_UUID_AES> += C<KDF_UUID_AES_CHALLENGE_RESPONSE> +This is what KeePassXC calls C<KDF_AES_KDBX4>. += C<KDF_UUID_ARGON2D> += C<KDF_UUID_ARGON2ID> += C<KDF_PARAM_UUID> += C<KDF_PARAM_AES_ROUNDS> += C<KDF_PARAM_AES_SEED> += C<KDF_PARAM_ARGON2_SALT> += C<KDF_PARAM_ARGON2_PARALLELISM> += C<KDF_PARAM_ARGON2_MEMORY> += C<KDF_PARAM_ARGON2_ITERATIONS> += C<KDF_PARAM_ARGON2_VERSION> += C<KDF_PARAM_ARGON2_SECRET> += C<KDF_PARAM_ARGON2_ASSOCDATA> += C<KDF_DEFAULT_AES_ROUNDS> += C<KDF_DEFAULT_ARGON2_ITERATIONS> += C<KDF_DEFAULT_ARGON2_MEMORY> += C<KDF_DEFAULT_ARGON2_PARALLELISM> += C<KDF_DEFAULT_ARGON2_VERSION> + +=head2 :variant_map + +Constants related to parsing and generating KDBX4 variant maps: + +=for :list += C<VMAP_VERSION> += C<VMAP_VERSION_MAJOR_MASK> += C<VMAP_TYPE_END> += C<VMAP_TYPE_UINT32> += C<VMAP_TYPE_UINT64> += C<VMAP_TYPE_BOOL> += C<VMAP_TYPE_INT32> += C<VMAP_TYPE_INT64> += C<VMAP_TYPE_STRING> += C<VMAP_TYPE_BYTEARRAY> + +=head2 :inner_header + +Constants related to parsing and generating KDBX4 inner headers: + +=for :list += C<INNER_HEADER_END> += C<INNER_HEADER_INNER_RANDOM_STREAM_ID> += C<INNER_HEADER_INNER_RANDOM_STREAM_KEY> += C<INNER_HEADER_BINARY> += C<INNER_HEADER_BINARY_FLAG_PROTECT> += C<KDBX_INNER_HEADER> + +=head2 :key_file + +Constants related to identifying key file types: + +=for :list += C<KEY_FILE_TYPE_BINARY> += C<KEY_FILE_TYPE_HASHED> += C<KEY_FILE_TYPE_HEX> += C<KEY_FILE_TYPE_XML> + +=head2 :history + +Constants for history-related default values: + +=for :list += C<HISTORY_DEFAULT_MAX_ITEMS> += C<HISTORY_DEFAULT_MAX_SIZE> + +=head2 :icon + +Constants for default icons used by KeePass password safe implementations: + +=for :list += C<ICON_PASSWORD> += C<ICON_PACKAGE_NETWORK> += C<ICON_MESSAGEBOX_WARNING> += C<ICON_SERVER> += C<ICON_KLIPPER> += C<ICON_EDU_LANGUAGES> += C<ICON_KCMDF> += C<ICON_KATE> += C<ICON_SOCKET> += C<ICON_IDENTITY> += C<ICON_KONTACT> += C<ICON_CAMERA> += C<ICON_IRKICKFLASH> += C<ICON_KGPG_KEY3> += C<ICON_LAPTOP_POWER> += C<ICON_SCANNER> += C<ICON_MOZILLA_FIREBIRD> += C<ICON_CDROM_UNMOUNT> += C<ICON_DISPLAY> += C<ICON_MAIL_GENERIC> += C<ICON_MISC> += C<ICON_KORGANIZER> += C<ICON_ASCII> += C<ICON_ICONS> += C<ICON_CONNECT_ESTABLISHED> += C<ICON_FOLDER_MAIL> += C<ICON_FILESAVE> += C<ICON_NFS_UNMOUNT> += C<ICON_MESSAGE> += C<ICON_KGPG_TERM> += C<ICON_KONSOLE> += C<ICON_FILEPRINT> += C<ICON_FSVIEW> += C<ICON_RUN> += C<ICON_CONFIGURE> += C<ICON_KRFB> += C<ICON_ARK> += C<ICON_KPERCENTAGE> += C<ICON_SAMBA_UNMOUNT> += C<ICON_HISTORY> += C<ICON_MAIL_FIND> += C<ICON_VECTORGFX> += C<ICON_KCMMEMORY> += C<ICON_TRASHCAN_FULL> += C<ICON_KNOTES> += C<ICON_CANCEL> += C<ICON_HELP> += C<ICON_KPACKAGE> += C<ICON_FOLDER> += C<ICON_FOLDER_BLUE_OPEN> += C<ICON_FOLDER_TAR> += C<ICON_DECRYPTED> += C<ICON_ENCRYPTED> += C<ICON_APPLY> += C<ICON_SIGNATURE> += C<ICON_THUMBNAIL> += C<ICON_KADDRESSBOOK> += C<ICON_VIEW_TEXT> += C<ICON_KGPG> += C<ICON_PACKAGE_DEVELOPMENT> += C<ICON_KFM_HOME> += C<ICON_SERVICES> += C<ICON_TUX> += C<ICON_FEATHER> += C<ICON_APPLE> += C<ICON_W> += C<ICON_MONEY> += C<ICON_CERTIFICATE> += C<ICON_SMARTPHONE> + +=head2 :time + +Constants related to time: + +=for :list += C<TIME_SECONDS_AD1_TO_UNIX_EPOCH> + +=head2 :yubikey + +Constants related to working with YubiKeys: + +=for :list += C<YUBICO_VID> += C<YUBIKEY_PID> += C<NEO_OTP_PID> += C<NEO_OTP_CCID_PID> += C<NEO_CCID_PID> += C<NEO_U2F_PID> += C<NEO_OTP_U2F_PID> += C<NEO_U2F_CCID_PID> += C<NEO_OTP_U2F_CCID_PID> += C<YK4_OTP_PID> += C<YK4_U2F_PID> += C<YK4_OTP_U2F_PID> += C<YK4_CCID_PID> += C<YK4_OTP_CCID_PID> += C<YK4_U2F_CCID_PID> += C<YK4_OTP_U2F_CCID_PID> += C<PLUS_U2F_OTP_PID> += C<ONLYKEY_VID> += C<ONLYKEY_PID> += C<YK_EUSBERR> += C<YK_EWRONGSIZ> += C<YK_EWRITEERR> += C<YK_ETIMEOUT> += C<YK_ENOKEY> += C<YK_EFIRMWARE> += C<YK_ENOMEM> += C<YK_ENOSTATUS> += C<YK_ENOTYETIMPL> += C<YK_ECHECKSUM> += C<YK_EWOULDBLOCK> += C<YK_EINVALIDCMD> += C<YK_EMORETHANONE> += C<YK_ENODATA> += C<CONFIG1_VALID> += C<CONFIG2_VALID> += C<CONFIG1_TOUCH> += C<CONFIG2_TOUCH> += C<CONFIG_LED_INV> += C<CONFIG_STATUS_MASK> + +=cut diff --git a/lib/File/KDBX/Dumper.pm b/lib/File/KDBX/Dumper.pm new file mode 100644 index 0000000..553b1f1 --- /dev/null +++ b/lib/File/KDBX/Dumper.pm @@ -0,0 +1,351 @@ +package File::KDBX::Dumper; +# ABSTRACT: Write KDBX files + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use File::KDBX::Constants qw(:magic :header :version :random_stream); +use File::KDBX::Error; +use File::KDBX; +use IO::Handle; +use Module::Load; +use Ref::Util qw(is_ref is_scalarref); +use Scalar::Util qw(looks_like_number openhandle); +use namespace::clean; + +our $VERSION = '999.999'; # VERSION + +=method new + + $dumper = File::KDBX::Dumper->new(%attributes); + +Construct a new L<File::KDBX::Dumper>. + +=cut + +sub new { + my $class = shift; + my $self = bless {}, $class; + $self->init(@_); +} + +=method init + + $dumper = $dumper->init(%attributes); + +Initialize a L<File::KDBX::Dumper> with a new set of attributes. + +This is called by L</new>. + +=cut + +sub init { + my $self = shift; + my %args = @_; + + @$self{keys %args} = values %args; + + return $self; +} + +sub _rebless { + my $self = shift; + my $format = shift // $self->format; + + my $version = $self->kdbx->version; + + my $subclass; + + if (defined $format) { + $subclass = $format; + } + elsif (!defined $version) { + $subclass = 'XML'; + } + elsif ($self->kdbx->sig2 == KDBX_SIG2_1) { + $subclass = 'KDB'; + } + elsif (looks_like_number($version)) { + my $major = $version & KDBX_VERSION_MAJOR_MASK; + my %subclasses = ( + KDBX_VERSION_2_0() => 'V3', + KDBX_VERSION_3_0() => 'V3', + KDBX_VERSION_4_0() => 'V4', + ); + if ($major == KDBX_VERSION_2_0) { + alert sprintf("Upgrading KDBX version %x to version %x\n", $version, KDBX_VERSION_3_1); + $self->kdbx->version(KDBX_VERSION_3_1); + } + $subclass = $subclasses{$major} + or throw sprintf('Unsupported KDBX file version: %x', $version), version => $version; + } + else { + throw sprintf('Unknown file version: %s', $version), version => $version; + } + + load "File::KDBX::Dumper::$subclass"; + bless $self, "File::KDBX::Dumper::$subclass"; +} + +=method reset + + $dumper = $dumper->reset; + +Set a L<File::KDBX::Dumper> to a blank state, ready to dumper another KDBX file. + +=cut + +sub reset { + my $self = shift; + %$self = (); + return $self; +} + +=method dump + + $dumper->dump(\$string, $key); + $dumper->dump(*IO, $key); + $dumper->dump($filepath, $key); + +Dump a KDBX file. + +The C<$key> is either a L<File::KDBX::Key> or a primitive that can be converted to a Key object. + +=cut + +sub dump { + my $self = shift; + my $dst = shift; + return $self->dump_handle($dst, @_) if openhandle($dst); + return $self->dump_string($dst, @_) if is_scalarref($dst); + return $self->dump_file($dst, @_) if defined $dst && !is_ref($dst); + throw 'Programmer error: Must pass a stringref, filepath or IO handle to dump'; +} + +=method dump_string + + $dumper->dump_string(\$string, $key); + \$string = $dumper->dump_string($key); + +Dump a KDBX file to a string / memory buffer. + +=cut + +sub dump_string { + my $self = shift; + my $ref = is_scalarref($_[0]) ? shift : undef; + my %args = @_ % 2 == 0 ? @_ : (key => shift, @_); + + my $key = delete $args{key}; + $args{kdbx} //= $self->kdbx; + + $ref //= do { + my $buf = ''; + \$buf; + }; + + open(my $fh, '>', $ref) or throw "Failed to open string buffer: $!"; + + $self = $self->new if !ref $self; + $self->init(%args, fh => $fh)->_dump($fh, $key); + + return $ref; +} + +=method dump_file + + $dumper->dump_file($filepath, $key); + +Dump a KDBX file to a filesystem. + +=cut + +sub dump_file { + my $self = shift; + my $filepath = shift; + my %args = @_ % 2 == 0 ? @_ : (key => shift, @_); + + my $key = delete $args{key}; + $args{kdbx} //= $self->kdbx; + + # require File::Temp; + # # my ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", CLEANUP => 1) }; + # my $fh = eval { File::Temp->new(TEMPLATE => "${filepath}-XXXXXX", CLEANUP => 1) }; + # my $filepath_temp = $fh->filename; + # if (!$fh or my $err = $@) { + # $err //= 'Unknown error'; + # throw sprintf('Open file failed (%s): %s', $filepath_temp, $err), + # error => $err, + # filepath => $filepath_temp; + # } + open(my $fh, '>:raw', $filepath) or die "open failed ($filepath): $!"; + binmode($fh); + # $fh->autoflush(1); + + $self = $self->new if !ref $self; + $self->init(%args, fh => $fh, filepath => $filepath); + # binmode($fh); + $self->_dump($fh, $key); + + # binmode($fh, ':raw'); + # close($fh); + + # my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5]; + + # my $mode = $args{mode} // $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef }; + # my $uid = $args{uid} // $file_uid // -1; + # my $gid = $args{gid} // $file_gid // -1; + # chmod($mode, $filepath_temp) if defined $mode; + # chown($uid, $gid, $filepath_temp); + # rename($filepath_temp, $filepath) or throw "Failed to write file ($filepath): $!", filepath => $filepath; + + return $self; +} + +=method dump_handle + + $dumper->dump_handle($fh, $key); + $dumper->dump_handle(*IO, $key); + +Dump a KDBX file to an input stream / file handle. + +=cut + +sub dump_handle { + my $self = shift; + my $fh = shift; + my %args = @_ % 2 == 0 ? @_ : (key => shift, @_); + + $fh = *STDOUT if $fh eq '-'; + + my $key = delete $args{key}; + $args{kdbx} //= $self->kdbx; + + $self = $self->new if !ref $self; + $self->init(%args, fh => $fh)->_dump($fh, $key); +} + +=attr kdbx + + $kdbx = $dumper->kdbx; + $dumper->kdbx($kdbx); + +Get or set the L<File::KDBX> instance with the data to be dumped. + +=cut + +sub kdbx { + my $self = shift; + return File::KDBX->new if !ref $self; + $self->{kdbx} = shift if @_; + $self->{kdbx} //= File::KDBX->new; +} + +=attr format + +=cut + +sub format { $_[0]->{format} } +sub inner_format { $_[0]->{inner_format} // 'XML' } + +=attr min_version + + $min_version = File::KDBX::Dumper->min_version; + +Get the minimum KDBX file version supported, which is 3.0 or C<0x00030000> as +it is encoded. + +To generate older KDBX files unsupported by this module, try L<File::KeePass>. + +=cut + +sub min_version { KDBX_VERSION_OLDEST } + +sub upgrade { $_[0]->{upgrade} // 1 } + +sub randomize_seeds { $_[0]->{randomize_seeds} // 1 } + +sub _fh { $_[0]->{fh} or throw 'IO handle not set' } + +sub _dump { + my $self = shift; + my $fh = shift; + my $key = shift; + + my $kdbx = $self->kdbx; + + my $min_version = $kdbx->minimum_version; + if ($kdbx->version < $min_version && $self->upgrade) { + alert sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version), + version => $kdbx->version, min_version => $min_version; + $kdbx->version($min_version); + } + $self->_rebless; + + if (ref($self) =~ /::(?:KDB|V[34])$/) { + $key //= $kdbx->key ? $kdbx->key->reload : undef; + defined $key or throw 'Must provide a master key', type => 'key.missing'; + } + + $self->_prepare; + + my $magic = $self->_write_magic_numbers($fh); + my $headers = $self->_write_headers($fh); + + $kdbx->unlock; + + $self->_write_body($fh, $key, "$magic$headers"); + + return $kdbx; +} + +sub _prepare { + my $self = shift; + my $kdbx = $self->kdbx; + + if ($kdbx->version < KDBX_VERSION_4_0) { + # force Salsa20 inner random stream + $kdbx->inner_random_stream_id(STREAM_ID_SALSA20); + my $key = $kdbx->inner_random_stream_key; + substr($key, 32) = ''; + $kdbx->inner_random_stream_key($key); + } + + $kdbx->randomize_seeds if $self->randomize_seeds; +} + +sub _write_magic_numbers { + my $self = shift; + my $fh = shift; + + my $kdbx = $self->kdbx; + + $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', sig1 => $kdbx->sig1; + $kdbx->version < $self->min_version || KDBX_VERSION_LATEST < $kdbx->version + and throw 'Unsupported file version', version => $kdbx->version; + + my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version); + + my $buf = pack('L<3', @magic); + $fh->print($buf) or throw 'Failed to write file signature'; + + return $buf; +} + +sub _write_headers { die "Not implemented" } + +sub _write_body { die "Not implemented" } + +sub _write_inner_body { + my $self = shift; + + my $current_pkg = ref $self; + require Scope::Guard; + my $guard = Scope::Guard->new(sub { bless $self, $current_pkg }); + + $self->_rebless($self->inner_format); + $self->_write_inner_body(@_); +} + +1; diff --git a/lib/File/KDBX/Dumper/KDB.pm b/lib/File/KDBX/Dumper/KDB.pm new file mode 100644 index 0000000..b1d5ba7 --- /dev/null +++ b/lib/File/KDBX/Dumper/KDB.pm @@ -0,0 +1,138 @@ +package File::KDBX::Dumper::KDB; +# ABSTRACT: Write KDB files + +use warnings; +use strict; + +use Crypt::PRNG qw(irand); +use Encode qw(encode); +use File::KDBX::Constants qw(:magic); +use File::KDBX::Error; +use File::KDBX::Loader::KDB; +use File::KDBX::Util qw(:uuid load_optional); +use namespace::clean; + +use parent 'File::KDBX::Dumper'; + +our $VERSION = '999.999'; # VERSION + +sub _write_magic_numbers { '' } +sub _write_headers { '' } + +sub _write_body { + my $self = shift; + my $fh = shift; + my $key = shift; + + load_optional(qw{File::KeePass File::KeePass::KDBX}); + + my $k = File::KeePass::KDBX->new($self->kdbx)->to_fkp; + $self->_write_custom_icons($self->kdbx, $k); + + # TODO create a KPX_CUSTOM_ICONS_4 meta stream. FKP itself handles KPX_GROUP_TREE_STATE + + substr($k->header->{seed_rand}, 16) = ''; + + $key = $self->kdbx->composite_key($key, keep_primitive => 1); + + my $dump = eval { $k->gen_db(File::KDBX::Loader::KDB::_convert_kdbx_to_keepass_master_key($key)) }; + if (my $err = $@) { + throw 'Failed to generate KDB file', error => $err; + } + + $self->kdbx->key($key); + + print $fh $dump; +} + +sub _write_custom_icons { + my $self = shift; + my $kdbx = shift; + my $k = shift; + + return if $kdbx->sig2 != KDBX_SIG2_1; + return if $k->find_entries({ + title => 'Meta-Info', + username => 'SYSTEM', + url => '$', + comment => 'KPX_CUSTOM_ICONS_4', + }); + + my @icons; # icon data + my %icons; # icon uuid -> index + my %entries; # id -> index + my %groups; # id -> index + my %gid; + + for my $uuid (sort keys %{$kdbx->custom_icons}) { + my $icon = $kdbx->custom_icons->{$uuid}; + my $data = $icon->{data} or next; + push @icons, $data; + $icons{$uuid} = $#icons; + } + for my $entry ($k->find_entries({})) { + my $icon_uuid = $entry->{custom_icon_uuid} // next; + my $icon_index = $icons{$icon_uuid} // next; + + $entry->{id} //= generate_uuid; + next if $entries{$entry->{id}}; + + $entries{$entry->{id}} = $icon_index; + } + for my $group ($k->find_groups({})) { + $gid{$group->{id} || ''}++; + my $icon_uuid = $group->{custom_icon_uuid} // next; + my $icon_index = $icons{$icon_uuid} // next; + + if ($group->{id} =~ /^[A-Fa-f0-9]{16}$/) { + $group->{id} = hex($group->{id}); + } + elsif ($group->{id} !~ /^\d+$/) { + do { + $group->{id} = irand; + } while $gid{$group->{id}}; + } + $gid{$group->{id}}++; + next if $groups{$group->{id}}; + + $groups{$group->{id}} = $icon_index; + } + + return if !@icons; + + my $stream = ''; + $stream .= pack('L<3', scalar @icons, scalar keys %entries, scalar keys %groups); + for (my $i = 0; $i < @icons; ++$i) { + $stream .= pack('L<', length($icons[$i])); + $stream .= $icons[$i]; + } + while (my ($id, $icon_index) = each %entries) { + $stream .= pack('a16 L<', $id, $icon_index); + } + while (my ($id, $icon_index) = each %groups) { + $stream .= pack('L<2', $id, $icon_index); + } + + $k->add_entry({ + comment => 'KPX_CUSTOM_ICONS_4', + title => 'Meta-Info', + username => 'SYSTEM', + url => '$', + id => '0' x 16, + icon => 0, + binary => {'bin-stream' => $stream}, + }); +} + +1; +__END__ + +=head1 DESCRIPTION + +Dump older KDB (KeePass 1) files. This feature requires additional modules to be installed: + +=for :list +* L<File::KeePass> +* L<File::KeePass::KDBX> + +=cut diff --git a/lib/File/KDBX/Dumper/Raw.pm b/lib/File/KDBX/Dumper/Raw.pm new file mode 100644 index 0000000..00205c8 --- /dev/null +++ b/lib/File/KDBX/Dumper/Raw.pm @@ -0,0 +1,61 @@ +package File::KDBX::Dumper::Raw; +# ABSTRACT: A no-op dumper that dumps content as-is + +use warnings; +use strict; + +use parent 'File::KDBX::Dumper'; + +our $VERSION = '999.999'; # VERSION + +sub _dump { + my $self = shift; + my $fh = shift; + + $self->_write_body($fh); +} + +sub _write_headers { '' } + +sub _write_body { + my $self = shift; + my $fh = shift; + + $self->_write_inner_body($fh); +} + +sub _write_inner_body { + my $self = shift; + my $fh = shift; + + $fh->print($self->kdbx->raw); +} + +1; +__END__ + +=head1 SYNOPSIS + + use File::KDBX::Dumper; + use File::KDBX; + + my $kdbx = File::KDBX->new; + $kdbx->raw("Secret file contents\n"); + + $kdbx->dump_file('file.kdbx', $key, inner_format => 'Raw'); + # OR + File::KDBX::Dumper->dump_file('file.kdbx', $key, + kdbx => $kdbx, + inner_format => 'Raw', + ); + +=head1 DESCRIPTION + +A typical KDBX file is made up of an outer section (with headers) and an inner section (with the body). The +inner section is usually dumped using L<File::KDBX::Dumper::XML>, but you can use the +B<File::KDBX::Dumper::Raw> dumper to just write some arbitrary data as the body content. The result won't +necessarily be parseable by typical KeePass implementations, but it can be read back using +L<File::KDBX::Loader::Raw>. It's a way to encrypt any file with the same high level of security as a KDBX +database. + +=cut diff --git a/lib/File/KDBX/Dumper/V3.pm b/lib/File/KDBX/Dumper/V3.pm new file mode 100644 index 0000000..890af02 --- /dev/null +++ b/lib/File/KDBX/Dumper/V3.pm @@ -0,0 +1,177 @@ +package File::KDBX::Dumper::V3; +# ABSTRACT: Dump KDBX3 files + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Encode qw(encode); +use File::KDBX::Constants qw(:header :compression); +use File::KDBX::Error; +use File::KDBX::Util qw(:empty assert_64bit erase_scoped); +use IO::Handle; +use PerlIO::via::File::KDBX::Crypt; +use PerlIO::via::File::KDBX::HashBlock; +use namespace::clean; + +use parent 'File::KDBX::Dumper'; + +our $VERSION = '999.999'; # VERSION + +sub _write_headers { + my $self = shift; + my $fh = shift; + + my $kdbx = $self->kdbx; + my $headers = $kdbx->headers; + my $buf = ''; + + # FIXME kinda janky - maybe add a "prepare" hook to massage the KDBX into the correct shape before we get + # this far + local $headers->{+HEADER_TRANSFORM_SEED} = $kdbx->transform_seed; + local $headers->{+HEADER_TRANSFORM_ROUNDS} = $kdbx->transform_rounds; + + if (nonempty (my $comment = $headers->{+HEADER_COMMENT})) { + $buf .= $self->_write_header($fh, HEADER_COMMENT, $comment); + } + for my $type ( + HEADER_CIPHER_ID, + HEADER_COMPRESSION_FLAGS, + HEADER_MASTER_SEED, + HEADER_TRANSFORM_SEED, + HEADER_TRANSFORM_ROUNDS, + HEADER_ENCRYPTION_IV, + HEADER_INNER_RANDOM_STREAM_KEY, + HEADER_STREAM_START_BYTES, + HEADER_INNER_RANDOM_STREAM_ID, + ) { + defined $headers->{$type} or throw "Missing value for required header: $type", type => $type; + $buf .= $self->_write_header($fh, $type, $headers->{$type}); + } + $buf .= $self->_write_header($fh, HEADER_END); + + return $buf; +} + +sub _write_header { + my $self = shift; + my $fh = shift; + my $type = shift; + my $val = shift // ''; + + $type = KDBX_HEADER($type); + if ($type == HEADER_END) { + $val = "\r\n\r\n"; + } + elsif ($type == HEADER_COMMENT) { + $val = encode('UTF-8', $val); + } + elsif ($type == HEADER_CIPHER_ID) { + my $size = length($val); + $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size; + } + elsif ($type == HEADER_COMPRESSION_FLAGS) { + $val = pack('L<', $val); + } + elsif ($type == HEADER_MASTER_SEED) { + my $size = length($val); + $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size; + } + elsif ($type == HEADER_TRANSFORM_SEED) { + # nothing + } + elsif ($type == HEADER_TRANSFORM_ROUNDS) { + assert_64bit; + $val = pack('Q<', $val); + } + elsif ($type == HEADER_ENCRYPTION_IV) { + # nothing + } + elsif ($type == HEADER_INNER_RANDOM_STREAM_KEY) { + # nothing + } + elsif ($type == HEADER_STREAM_START_BYTES) { + # nothing + } + elsif ($type == HEADER_INNER_RANDOM_STREAM_ID) { + $val = pack('L<', $val); + } + elsif ($type == HEADER_KDF_PARAMETERS || + $type == HEADER_PUBLIC_CUSTOM_DATA) { + throw "Unexpected KDBX4 header: $type", type => $type; + } + elsif ($type == HEADER_COMMENT) { + throw "Unexpected KDB header: $type", type => $type; + } + else { + alert "Unknown header: $type", type => $type; + } + + my $size = length($val); + my $buf = pack('C S<', 0+$type, $size); + + $fh->print($buf, $val) or throw 'Failed to write header'; + + return "$buf$val"; +} + +sub _write_body { + my $self = shift; + my $fh = shift; + my $key = shift; + my $header_data = shift; + my $kdbx = $self->kdbx; + + # assert all required headers present + for my $field ( + HEADER_CIPHER_ID, + HEADER_ENCRYPTION_IV, + HEADER_MASTER_SEED, + HEADER_INNER_RANDOM_STREAM_KEY, + HEADER_STREAM_START_BYTES, + ) { + defined $kdbx->headers->{$field} or throw "Missing $field"; + } + + my $master_seed = $kdbx->headers->{+HEADER_MASTER_SEED}; + + my @cleanup; + $key = $kdbx->composite_key($key); + + my $response = $key->challenge($master_seed); + push @cleanup, erase_scoped $response; + + my $transformed_key = $kdbx->kdf->transform($key); + push @cleanup, erase_scoped $transformed_key; + + my $final_key = digest_data('SHA256', $master_seed, $response, $transformed_key); + push @cleanup, erase_scoped $final_key; + + my $cipher = $kdbx->cipher(key => $final_key); + PerlIO::via::File::KDBX::Crypt->push($fh, $cipher); + + $fh->print($kdbx->headers->{+HEADER_STREAM_START_BYTES}) + or throw 'Failed to write start bytes'; + $fh->flush; + + $kdbx->key($key); + + PerlIO::via::File::KDBX::HashBlock->push($fh); + + my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS}; + if ($compress == COMPRESSION_GZIP) { + require PerlIO::via::File::KDBX::Compression; + PerlIO::via::File::KDBX::Compression->push($fh); + } + elsif ($compress != COMPRESSION_NONE) { + throw "Unsupported compression ($compress)\n", compression_flags => $compress; + } + + my $header_hash = digest_data('SHA256', $header_data); + $self->_write_inner_body($fh, $header_hash); + + binmode($fh, ':pop') if $compress; + binmode($fh, ':pop:pop'); +} + +1; diff --git a/lib/File/KDBX/Dumper/V4.pm b/lib/File/KDBX/Dumper/V4.pm new file mode 100644 index 0000000..b96e568 --- /dev/null +++ b/lib/File/KDBX/Dumper/V4.pm @@ -0,0 +1,366 @@ +package File::KDBX::Dumper::V4; +# ABSTRACT: Dump KDBX4 files + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Crypt::Mac::HMAC qw(hmac); +use Encode qw(encode is_utf8); +use File::KDBX::Constants qw(:header :inner_header :compression :kdf :variant_map); +use File::KDBX::Error; +use File::KDBX::Util qw(:empty assert_64bit erase_scoped); +use IO::Handle; +use PerlIO::via::File::KDBX::Crypt; +use PerlIO::via::File::KDBX::HmacBlock; +use Scalar::Util qw(looks_like_number); +use boolean qw(:all); +use namespace::clean; + +use parent 'File::KDBX::Dumper'; + +our $VERSION = '999.999'; # VERSION + +sub _binaries_written { $_[0]->{_binaries_written} //= {} } + +sub _write_headers { + my $self = shift; + my $fh = shift; + + my $kdbx = $self->kdbx; + my $headers = $kdbx->headers; + my $buf = ''; + + # Always write the standard AES KDF UUID, for compatibility + local $headers->{+HEADER_KDF_PARAMETERS}->{+KDF_PARAM_UUID} = KDF_UUID_AES + if $headers->{+HEADER_KDF_PARAMETERS}->{+KDF_PARAM_UUID} eq KDF_UUID_AES_CHALLENGE_RESPONSE; + + if (nonempty (my $comment = $headers->{+HEADER_COMMENT})) { + $buf .= $self->_write_header($fh, HEADER_COMMENT, $comment); + } + for my $type ( + HEADER_CIPHER_ID, + HEADER_COMPRESSION_FLAGS, + HEADER_MASTER_SEED, + HEADER_ENCRYPTION_IV, + HEADER_KDF_PARAMETERS, + ) { + defined $headers->{$type} or throw "Missing value for required header: $type", type => $type; + $buf .= $self->_write_header($fh, $type, $headers->{$type}); + } + $buf .= $self->_write_header($fh, HEADER_PUBLIC_CUSTOM_DATA, $headers->{+HEADER_PUBLIC_CUSTOM_DATA}) + if defined $headers->{+HEADER_PUBLIC_CUSTOM_DATA} && keys %{$headers->{+HEADER_PUBLIC_CUSTOM_DATA}}; + $buf .= $self->_write_header($fh, HEADER_END); + + return $buf; +} + +sub _write_header { + my $self = shift; + my $fh = shift; + my $type = shift; + my $val = shift // ''; + + $type = KDBX_HEADER($type); + if ($type == HEADER_END) { + # nothing + } + elsif ($type == HEADER_COMMENT) { + $val = encode('UTF-8', $val); + } + elsif ($type == HEADER_CIPHER_ID) { + my $size = length($val); + $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size; + } + elsif ($type == HEADER_COMPRESSION_FLAGS) { + $val = pack('L<', $val); + } + elsif ($type == HEADER_MASTER_SEED) { + my $size = length($val); + $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size; + } + elsif ($type == HEADER_ENCRYPTION_IV) { + # nothing + } + elsif ($type == HEADER_KDF_PARAMETERS) { + $val = $self->_write_variant_dictionary($val, { + KDF_PARAM_UUID() => VMAP_TYPE_BYTEARRAY, + KDF_PARAM_AES_ROUNDS() => VMAP_TYPE_UINT64, + KDF_PARAM_AES_SEED() => VMAP_TYPE_BYTEARRAY, + KDF_PARAM_ARGON2_SALT() => VMAP_TYPE_BYTEARRAY, + KDF_PARAM_ARGON2_PARALLELISM() => VMAP_TYPE_UINT32, + KDF_PARAM_ARGON2_MEMORY() => VMAP_TYPE_UINT64, + KDF_PARAM_ARGON2_ITERATIONS() => VMAP_TYPE_UINT64, + KDF_PARAM_ARGON2_VERSION() => VMAP_TYPE_UINT32, + KDF_PARAM_ARGON2_SECRET() => VMAP_TYPE_BYTEARRAY, + KDF_PARAM_ARGON2_ASSOCDATA() => VMAP_TYPE_BYTEARRAY, + }); + } + elsif ($type == HEADER_PUBLIC_CUSTOM_DATA) { + $val = $self->_write_variant_dictionary($val); + } + elsif ($type == HEADER_INNER_RANDOM_STREAM_ID || + $type == HEADER_INNER_RANDOM_STREAM_KEY || + $type == HEADER_TRANSFORM_SEED || + $type == HEADER_TRANSFORM_ROUNDS || + $type == HEADER_STREAM_START_BYTES) { + throw "Unexpected KDBX3 header: $type", type => $type; + } + elsif ($type == HEADER_COMMENT) { + throw "Unexpected KDB header: $type", type => $type; + } + else { + alert "Unknown header: $type", type => $type; + } + + my $size = length($val); + my $buf = pack('C L<', 0+$type, $size); + + $fh->print($buf, $val) or throw 'Failed to write header'; + + return "$buf$val"; +} + +sub _intuit_variant_type { + my $self = shift; + my $variant = shift; + + if (isBoolean($variant)) { + return VMAP_TYPE_BOOL; + } + elsif (looks_like_number($variant) && ($variant + 0) =~ /^\d+$/) { + assert_64bit; + my $neg = $variant < 0; + my @b = unpack('L>2', pack('Q>', $variant)); + return VMAP_TYPE_INT64 if $b[0] && $neg; + return VMAP_TYPE_UINT64 if $b[0]; + return VMAP_TYPE_INT32 if $neg; + return VMAP_TYPE_UINT32; + } + elsif (is_utf8($variant)) { + return VMAP_TYPE_STRING; + } + return VMAP_TYPE_BYTEARRAY; +} + +sub _write_variant_dictionary { + my $self = shift; + my $dict = shift || {}; + my $types = shift || {}; + + my $buf = ''; + + $buf .= pack('S<', VMAP_VERSION); + + for my $key (sort keys %$dict) { + my $val = $dict->{$key}; + + my $type = $types->{$key} // $self->_intuit_variant_type($val); + $buf .= pack('C', $type); + + if ($type == VMAP_TYPE_UINT32) { + $val = pack('L<', $val); + } + elsif ($type == VMAP_TYPE_UINT64) { + assert_64bit; + $val = pack('Q<', $val); + } + elsif ($type == VMAP_TYPE_BOOL) { + $val = pack('C', $val); + } + elsif ($type == VMAP_TYPE_INT32) { + $val = pack('l', $val); + } + elsif ($type == VMAP_TYPE_INT64) { + assert_64bit; + $val = pack('q<', $val); + } + elsif ($type == VMAP_TYPE_STRING) { + $val = encode('UTF-8', $val); + } + elsif ($type == VMAP_TYPE_BYTEARRAY) { + # $val = substr($$buf, $pos, $vlen); + # $val = [split //, $val]; + } + else { + throw 'Unknown variant dictionary value type', type => $type; + } + + my ($klen, $vlen) = (length($key), length($val)); + $buf .= pack("L< a$klen L< a$vlen", $klen, $key, $vlen, $val); + } + + $buf .= pack('C', VMAP_TYPE_END); + + return $buf; +} + +sub _write_body { + my $self = shift; + my $fh = shift; + my $key = shift; + my $header_data = shift; + my $kdbx = $self->kdbx; + + # assert all required headers present + for my $field ( + HEADER_CIPHER_ID, + HEADER_ENCRYPTION_IV, + HEADER_MASTER_SEED, + ) { + defined $kdbx->headers->{$field} or throw "Missing header: $field"; + } + + my @cleanup; + + # write 32-byte checksum + my $header_hash = digest_data('SHA256', $header_data); + $fh->print($header_hash) or throw 'Failed to write header hash'; + + $key = $kdbx->composite_key($key); + my $transformed_key = $kdbx->kdf->transform($key); + push @cleanup, erase_scoped $transformed_key; + + # write 32-byte HMAC for header + my $hmac_key = digest_data('SHA512', $kdbx->headers->{master_seed}, $transformed_key, "\x01"); + push @cleanup, erase_scoped $hmac_key; + my $header_hmac = hmac('SHA256', + digest_data('SHA512', "\xff\xff\xff\xff\xff\xff\xff\xff", $hmac_key), + $header_data, + ); + $fh->print($header_hmac) or throw 'Failed to write header HMAC'; + + $kdbx->key($key); + + # HMAC-block the rest of the stream + PerlIO::via::File::KDBX::HmacBlock->push($fh, $hmac_key); + + my $final_key = digest_data('SHA256', $kdbx->headers->{master_seed}, $transformed_key); + push @cleanup, erase_scoped $final_key; + + my $cipher = $kdbx->cipher(key => $final_key); + PerlIO::via::File::KDBX::Crypt->push($fh, $cipher); + + my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS}; + if ($compress == COMPRESSION_GZIP) { + require PerlIO::via::File::KDBX::Compression; + PerlIO::via::File::KDBX::Compression->push($fh); + } + elsif ($compress != COMPRESSION_NONE) { + throw "Unsupported compression ($compress)\n", compression_flags => $compress; + } + + $self->_write_inner_headers($fh); + + local $self->{compress_datetimes} = 1; + $self->_write_inner_body($fh, $header_hash); + + binmode($fh, ':pop') if $compress; + binmode($fh, ':pop:pop'); +} + +sub _write_inner_headers { + my $self = shift; + my $fh = shift; + + my $kdbx = $self->kdbx; + my $headers = $kdbx->inner_headers; + + for my $type ( + INNER_HEADER_INNER_RANDOM_STREAM_ID, + INNER_HEADER_INNER_RANDOM_STREAM_KEY, + ) { + defined $headers->{$type} or throw "Missing inner header: $type"; + $self->_write_inner_header($fh, $type => $headers->{$type}); + } + + $self->_write_binaries($fh); + + $self->_write_inner_header($fh, INNER_HEADER_END); +} + +sub _write_inner_header { + my $self = shift; + my $fh = shift; + my $type = shift; + my $val = shift // ''; + + my $buf = pack('C', $type); + $fh->print($buf) or throw 'Failed to write inner header type'; + + $type = KDBX_INNER_HEADER($type); + + if ($type == INNER_HEADER_END) { + # nothing + } + elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID) { + $val = pack('L<', $val); + } + elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY) { + # nothing + } + elsif ($type == INNER_HEADER_BINARY) { + # nothing + } + + $buf = pack('L<', length($val)); + $fh->print($buf) or throw 'Failed to write inner header value size'; + $fh->print($val) or throw 'Failed to write inner header value'; +} + +sub _write_binaries { + my $self = shift; + my $fh = shift; + + my $kdbx = $self->kdbx; + + my $new_ref = 0; + my $written = $self->_binaries_written; + + my $entries = $kdbx->all_entries(history => true); + for my $entry (@$entries) { + for my $key (keys %{$entry->binaries}) { + my $binary = $entry->binaries->{$key}; + if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) { + $binary = $kdbx->binaries->{$binary->{ref}}; + } + + if (!defined $binary->{value}) { + alert "Skipping binary which has no value: $key", key => $key; + next; + } + + my $hash = digest_data('SHA256', $binary->{value}); + if (defined $written->{$hash}) { + # nothing + } + else { + my $flags = 0; + $flags &= INNER_HEADER_BINARY_FLAG_PROTECT if $binary->{protect}; + + $self->_write_binary($fh, \$binary->{value}, $flags); + $written->{$hash} = $new_ref++; + } + } + } +} + +sub _write_binary { + my $self = shift; + my $fh = shift; + my $data = shift; + my $flags = shift || 0; + + my $buf = pack('C', 0 + INNER_HEADER_BINARY); + $fh->print($buf) or throw 'Failed to write inner header type'; + + $buf = pack('L<', 1 + length($$data)); + $fh->print($buf) or throw 'Failed to write inner header value size'; + + $buf = pack('C', $flags); + $fh->print($buf) or throw 'Failed to write inner header binary flags'; + + $fh->print($$data) or throw 'Failed to write inner header value'; +} + +1; diff --git a/lib/File/KDBX/Dumper/XML.pm b/lib/File/KDBX/Dumper/XML.pm new file mode 100644 index 0000000..23378b6 --- /dev/null +++ b/lib/File/KDBX/Dumper/XML.pm @@ -0,0 +1,575 @@ +package File::KDBX::Dumper::XML; +# ABSTRACT: Dump unencrypted XML KeePass files + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Crypt::Misc 0.029 qw(encode_b64); +use Encode qw(encode); +use File::KDBX::Constants qw(:version :time); +use File::KDBX::Error; +use File::KDBX::Util qw(assert_64bit erase_scoped gzip snakify); +use IO::Handle; +use Scalar::Util qw(isdual looks_like_number); +use Scope::Guard; +use Time::Piece; +use XML::LibXML; +use boolean; +use namespace::clean; + +use parent 'File::KDBX::Dumper'; + +our $VERSION = '999.999'; # VERSION + +sub protect { + my $self = shift; + $self->{protect} = shift if @_; + $self->{protect} //= 1; +} + +sub binaries { + my $self = shift; + $self->{binaries} = shift if @_; + $self->{binaries} //= $self->kdbx->version < KDBX_VERSION_4_0; +} + +sub compress_binaries { + my $self = shift; + $self->{compress_binaries} = shift if @_; + $self->{compress_binaries}; +} + +sub compress_datetimes { + my $self = shift; + $self->{compress_datetimes} = shift if @_; + $self->{compress_datetimes}; +} + +sub header_hash { $_[0]->{header_hash} } + +sub _binaries_written { $_[0]->{_binaries_written} //= {} } + +sub _random_stream { $_[0]->{random_stream} //= $_[0]->kdbx->random_stream } + +sub _dump { + my $self = shift; + my $fh = shift; + + $self->_write_inner_body($fh, $self->header_hash); +} + +sub _write_inner_body { + my $self = shift; + my $fh = shift; + my $header_hash = shift; + + my $dom = XML::LibXML::Document->new('1.0', 'UTF-8'); + $dom->setStandalone(1); + + my $doc = XML::LibXML::Element->new('KeePassFile'); + $dom->setDocumentElement($doc); + + my $meta = XML::LibXML::Element->new('Meta'); + $doc->appendChild($meta); + $self->_write_xml_meta($meta, $header_hash); + + my $root = XML::LibXML::Element->new('Root'); + $doc->appendChild($root); + $self->_write_xml_root($root); + + $dom->toFH($fh, 1); +} + +sub _write_xml_meta { + my $self = shift; + my $node = shift; + my $header_hash = shift; + + my $meta = $self->kdbx->meta; + local $meta->{generator} = $self->kdbx->user_agent_string // __PACKAGE__; + local $meta->{header_hash} = $header_hash; + + $self->_write_xml_from_pairs($node, $meta, + Generator => 'text', + $self->kdbx->version < KDBX_VERSION_4_0 && defined $meta->{header_hash} ? ( + HeaderHash => 'binary', + ) : (), + DatabaseName => 'text', + DatabaseNameChanged => 'datetime', + DatabaseDescription => 'text', + DatabaseDescriptionChanged => 'datetime', + DefaultUserName => 'text', + DefaultUserNameChanged => 'datetime', + MaintenanceHistoryDays => 'number', + Color => 'text', + MasterKeyChanged => 'datetime', + MasterKeyChangeRec => 'number', + MasterKeyChangeForce => 'number', + MemoryProtection => \&_write_xml_memory_protection, + CustomIcons => \&_write_xml_custom_icons, + RecycleBinEnabled => 'bool', + RecycleBinUUID => 'uuid', + RecycleBinChanged => 'datetime', + EntryTemplatesGroup => 'uuid', + EntryTemplatesGroupChanged => 'datetime', + LastSelectedGroup => 'uuid', + LastTopVisibleGroup => 'uuid', + HistoryMaxItems => 'number', + HistoryMaxSize => 'number', + $self->kdbx->version >= KDBX_VERSION_4_0 ? ( + SettingsChanged => 'datetime', + ) : (), + $self->kdbx->version < KDBX_VERSION_4_0 || $self->binaries ? ( + Binaries => \&_write_xml_binaries, + ) : (), + CustomData => \&_write_xml_custom_data, + ); +} + +sub _write_xml_memory_protection { + my $self = shift; + my $node = shift; + + my $memory_protection = $self->kdbx->meta->{memory_protection}; + + $self->_write_xml_from_pairs($node, $memory_protection, + ProtectTitle => 'bool', + ProtectUserName => 'bool', + ProtectPassword => 'bool', + ProtectURL => 'bool', + ProtectNotes => 'bool', + # AutoEnableVisualHiding => 'bool', + ); +} + +sub _write_xml_binaries { + my $self = shift; + my $node = shift; + + my $kdbx = $self->kdbx; + + my $new_ref = keys %{$self->_binaries_written}; + my $written = $self->_binaries_written; + + my $entries = $kdbx->all_entries(history => true); + for my $entry (@$entries) { + for my $key (keys %{$entry->binaries}) { + my $binary = $entry->binaries->{$key}; + if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) { + $binary = $kdbx->binaries->{$binary->{ref}}; + } + + if (!defined $binary->{value}) { + alert "Skipping binary which has no value: $key", key => $key; + next; + } + + my $hash = digest_data('SHA256', $binary->{value}); + if (defined $written->{$hash}) { + # nothing + } + else { + my $binary_node = $node->addNewChild(undef, 'Binary'); + $binary_node->setAttribute('ID', _encode_text($new_ref)); + $binary_node->setAttribute('Protected', _encode_bool(true)) if $binary->{protect}; + $self->_write_xml_compressed_content($binary_node, \$binary->{value}, $binary->{protect}); + $written->{$hash} = $new_ref++; + } + } + } +} + +sub _write_xml_compressed_content { + my $self = shift; + my $node = shift; + my $value = shift; + my $protect = shift; + + my @cleanup; + + my $encoded; + if (utf8::is_utf8($$value)) { + $encoded = encode('UTF-8', $$value); + push @cleanup, erase_scoped $encoded; + $value = \$encoded; + } + + my $always_compress = $self->compress_binaries; + my $try_compress = $always_compress || !defined $always_compress; + + my $compressed; + if ($try_compress) { + $compressed = gzip($$value); + push @cleanup, erase_scoped $compressed; + + if ($always_compress || length($compressed) < length($$value)) { + $value = \$compressed; + $node->setAttribute('Compressed', _encode_bool(true)); + } + } + + my $encrypted; + if ($protect) { + $encrypted = $self->_random_stream->crypt($$value); + push @cleanup, erase_scoped $encrypted; + $value = \$encrypted; + } + + $node->appendText(_encode_binary($$value)); +} + +sub _write_xml_custom_icons { + my $self = shift; + my $node = shift; + + my $custom_icons = $self->kdbx->meta->{custom_icons} || {}; + + for my $uuid (sort keys %$custom_icons) { + my $icon = $custom_icons->{$uuid}; + my $icon_node = $node->addNewChild(undef, 'Icon'); + + $self->_write_xml_from_pairs($icon_node, $icon, + UUID => 'uuid', + Data => 'binary', + KDBX_VERSION_4_1 <= $self->kdbx->version ? ( + Name => 'text', + LastModificationTime => 'datetime', + ) : (), + ); + } +} + +sub _write_xml_custom_data { + my $self = shift; + my $node = shift; + my $custom_data = shift || {}; + + for my $key (sort keys %$custom_data) { + my $item = $custom_data->{$key}; + my $item_node = $node->addNewChild(undef, 'Item'); + + local $item->{key} = $key if !defined $item->{key}; + + $self->_write_xml_from_pairs($item_node, $item, + Key => 'text', + Value => 'text', + KDBX_VERSION_4_1 <= $self->kdbx->version ? ( + LastModificationTime => 'datetime', + ) : (), + ); + } +} + +sub _write_xml_root { + my $self = shift; + my $node = shift; + my $kdbx = $self->kdbx; + + my $is_locked = $kdbx->is_locked; + my $guard = Scope::Guard->new(sub { $kdbx->lock if $is_locked }); + $kdbx->unlock; + + if (my $group = $kdbx->{root}) { + my $group_node = $node->addNewChild(undef, 'Group'); + $self->_write_xml_group($group_node, $group); + } + + undef $guard; # re-lock if needed, as early as possible + + my $deleted_objects_node = $node->addNewChild(undef, 'DeletedObjects'); + $self->_write_xml_deleted_objects($deleted_objects_node); +} + +sub _write_xml_group { + my $self = shift; + my $node = shift; + my $group = shift; + + $self->_write_xml_from_pairs($node, $group, + UUID => 'uuid', + Name => 'text', + Notes => 'text', + KDBX_VERSION_4_1 <= $self->kdbx->version ? ( + Tags => 'text', + ) : (), + IconID => 'number', + defined $group->{custom_icon_uuid} ? ( + CustomIconUUID => 'uuid', + ) : (), + Times => \&_write_xml_times, + IsExpanded => 'bool', + DefaultAutoTypeSequence => 'text', + EnableAutoType => 'tristate', + EnableSearching => 'tristate', + LastTopVisibleEntry => 'uuid', + KDBX_VERSION_4_0 <= $self->kdbx->version ? ( + CustomData => \&_write_xml_custom_data, + ) : (), + KDBX_VERSION_4_1 <= $self->kdbx->version ? ( + PreviousParentGroup => 'uuid', + ) : (), + ); + + for my $entry (@{$group->{entries} || []}) { + my $entry_node = $node->addNewChild(undef, 'Entry'); + $self->_write_xml_entry($entry_node, $entry); + } + + for my $group (@{$group->{groups} || []}) { + my $group_node = $node->addNewChild(undef, 'Group'); + $self->_write_xml_group($group_node, $group); + } +} + +sub _write_xml_entry { + my $self = shift; + my $node = shift; + my $entry = shift; + my $in_history = shift; + + $self->_write_xml_from_pairs($node, $entry, + UUID => 'uuid', + IconID => 'number', + defined $entry->{custom_icon_uuid} ? ( + CustomIconUUID => 'uuid', + ) : (), + ForegroundColor => 'text', + BackgroundColor => 'text', + OverrideURL => 'text', + Tags => 'text', + Times => \&_write_xml_times, + KDBX_VERSION_4_1 <= $self->kdbx->version ? ( + QualityCheck => 'bool', + PreviousParentGroup => 'uuid', + ) : (), + ); + + for my $key (sort keys %{$entry->{strings} || {}}) { + my $string = $entry->{strings}{$key}; + my $string_node = $node->addNewChild(undef, 'String'); + local $string->{key} = $string->{key} // $key; + $self->_write_xml_entry_string($string_node, $string); + } + + my $kdbx = $self->kdbx; + my $new_ref = keys %{$self->_binaries_written}; + my $written = $self->_binaries_written; + + for my $key (sort keys %{$entry->{binaries} || {}}) { + my $binary = $entry->binaries->{$key}; + if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) { + $binary = $kdbx->binaries->{$binary->{ref}}; + } + + if (!defined $binary->{value}) { + alert "Skipping binary which has no value: $key", key => $key; + next; + } + + my $binary_node = $node->addNewChild(undef, 'Binary'); + $binary_node->addNewChild(undef, 'Key')->appendText(_encode_text($key)); + my $value_node = $binary_node->addNewChild(undef, 'Value'); + + my $hash = digest_data('SHA256', $binary->{value}); + if (defined $written->{$hash}) { + # write reference + $value_node->setAttribute('Ref', _encode_text($written->{$hash})); + } + else { + # write actual binary + $value_node->setAttribute('Protected', _encode_bool(true)) if $binary->{protect}; + $self->_write_xml_compressed_content($value_node, \$binary->{value}, $binary->{protect}); + $written->{$hash} = $new_ref++; + } + } + + $self->_write_xml_from_pairs($node, $entry, + AutoType => \&_write_xml_entry_auto_type, + ); + + $self->_write_xml_from_pairs($node, $entry, + KDBX_VERSION_4_0 <= $self->kdbx->version ? ( + CustomData => \&_write_xml_custom_data, + ) : (), + ); + + if (!$in_history) { + if (my @history = @{$entry->{history} || []}) { + my $history_node = $node->addNewChild(undef, 'History'); + for my $historical (@history) { + my $historical_node = $history_node->addNewChild(undef, 'Entry'); + $self->_write_xml_entry($historical_node, $historical, 1); + } + } + } +} + +sub _write_xml_entry_auto_type { + my $self = shift; + my $node = shift; + my $autotype = shift; + + $self->_write_xml_from_pairs($node, $autotype, + Enabled => 'bool', + DataTransferObfuscation => 'number', + DefaultSequence => 'text', + ); + + for my $association (@{$autotype->{associations} || []}) { + my $association_node = $node->addNewChild(undef, 'Association'); + $self->_write_xml_from_pairs($association_node, $association, + Window => 'text', + KeystrokeSequence => 'text', + ); + } +} + +sub _write_xml_times { + my $self = shift; + my $node = shift; + my $times = shift; + + $self->_write_xml_from_pairs($node, $times, + LastModificationTime => 'datetime', + CreationTime => 'datetime', + LastAccessTime => 'datetime', + ExpiryTime => 'datetime', + Expires => 'bool', + UsageCount => 'number', + LocationChanged => 'datetime', + ); +} + +sub _write_xml_entry_string { + my $self = shift; + my $node = shift; + my $string = shift; + + my @cleanup; + + my $kdbx = $self->kdbx; + my $key = $string->{key}; + + $node->addNewChild(undef, 'Key')->appendText(_encode_text($key)); + my $value_node = $node->addNewChild(undef, 'Value'); + + my $value = $string->{value} || ''; + + my $memory_protection = $kdbx->meta->{memory_protection}; + my $memprot_key = 'protect_' . snakify($key); + my $protect = $string->{protect} || $memory_protection->{$memprot_key}; + + if ($protect) { + if ($self->protect) { + my $encoded; + if (utf8::is_utf8($value)) { + $encoded = encode('UTF-8', $value); + push @cleanup, erase_scoped $encoded; + $value = $encoded; + } + + $value_node->setAttribute('Protected', _encode_bool(true)); + $value = _encode_binary($self->_random_stream->crypt(\$value)); + } + else { + $value_node->setAttribute('ProtectInMemory', _encode_bool(true)); + $value = _encode_text($value); + } + } + else { + $value = _encode_text($value); + } + + $value_node->appendText($value) if defined $value; +} + +sub _write_xml_deleted_objects { + my $self = shift; + my $node = shift; + + my $objects = $self->kdbx->deleted_objects; + + for my $uuid (sort keys %{$objects || {}}) { + my $object = $objects->{$uuid}; + local $object->{uuid} = $uuid; + my $object_node = $node->addNewChild(undef, 'DeletedObject'); + $self->_write_xml_from_pairs($object_node, $object, + UUID => 'uuid', + DeletionTime => 'datetime', + ); + } +} + +############################################################################## + +sub _write_xml_from_pairs { + my $self = shift; + my $node = shift; + my $hash = shift; + my @spec = @_; + + while (@spec) { + my ($name, $type) = splice @spec, 0, 2; + my $key = snakify($name); + + if (ref $type eq 'CODE') { + my $child_node = $node->addNewChild(undef, $name); + $self->$type($child_node, $hash->{$key}); + } + else { + next if !exists $hash->{$key}; + my $child_node = $node->addNewChild(undef, $name); + $type = 'datetime_binary' if $type eq 'datetime' && $self->compress_datetimes; + $child_node->appendText(_encode_primitive($hash->{$key}, $type)); + } + } +} + +############################################################################## + +sub _encode_primitive { goto &{__PACKAGE__."::_encode_$_[1]"} } + +sub _encode_binary { + return '' if !defined $_[0] || (ref $_[0] && !defined $$_[0]); + return encode_b64(ref $_[0] ? $$_[0] : $_[0]); +} + +sub _encode_bool { + local $_ = shift; + return $_ ? 'True' : 'False'; +} + +sub _encode_datetime { + goto &_encode_datetime_binary if defined $_[2] && KDBX_VERSION_4_0 <= $_[2]; + local $_ = shift; + return $_->strftime('%Y-%m-%dT%H:%M:%SZ'); +} + +sub _encode_datetime_binary { + local $_ = shift; + assert_64bit; + my $seconds_since_ad1 = $_ + TIME_SECONDS_AD1_TO_UNIX_EPOCH; + my $buf = pack('Q<', $seconds_since_ad1->epoch); + return eval { encode_b64($buf) }; +} + +sub _encode_tristate { + local $_ = shift // return 'null'; + return $_ ? 'True' : 'False'; +} + +sub _encode_number { + local $_ = shift // return; + looks_like_number($_) || isdual($_) or throw 'Expected number', text => $_; + return _encode_text($_+0); +} + +sub _encode_text { + return '' if !defined $_[0]; + return $_[0]; +} + +sub _encode_uuid { _encode_binary(@_) } + +1; diff --git a/lib/File/KDBX/Entry.pm b/lib/File/KDBX/Entry.pm new file mode 100644 index 0000000..c3ddcb9 --- /dev/null +++ b/lib/File/KDBX/Entry.pm @@ -0,0 +1,1060 @@ +package File::KDBX::Entry; +# ABSTRACT: A KDBX database entry + +use warnings; +use strict; + +use Crypt::Misc 0.029 qw(encode_b32r decode_b64); +use Devel::GlobalDestruction; +use Encode qw(encode); +use File::KDBX::Constants qw(:history :icon); +use File::KDBX::Error; +use File::KDBX::Util qw(:function :uri generate_uuid load_optional); +use List::Util qw(sum0); +use Ref::Util qw(is_plain_hashref is_ref); +use Scalar::Util qw(looks_like_number refaddr); +use Storable qw(dclone); +use Time::Piece; +use boolean; +use namespace::clean; + +use parent 'File::KDBX::Object'; + +our $VERSION = '999.999'; # VERSION + +my $PLACEHOLDER_MAX_DEPTH = 10; +my %PLACEHOLDERS; +my %STANDARD_STRINGS = map { $_ => 1 } qw(Title UserName Password URL Notes); + +=attr uuid + +128-bit UUID identifying the entry within the database. + +=attr icon_id + +Integer representing a default icon. See L<File::KDBX::Constants/":icon"> for valid values. + +=attr custom_icon_uuid + +128-bit UUID identifying a custom icon within the database. + +=attr foreground_color + +Text color represented as a string of the form C<#000000>. + +=attr background_color + +Background color represented as a string of the form C<#FFFFFF>. + +=attr override_url + +TODO + +=attr tags + +Text string with arbitrary tags which can be used to build a taxonomy. + +=attr auto_type + +Auto-type details. + + { + enabled => true, + data_transfer_obfuscation => 0, + default_sequence => '{USERNAME}{TAB}{PASSWORD}{ENTER}', + associations => [ + { + window => 'My Bank - Mozilla Firefox', + keystroke_sequence => '{PASSWORD}{ENTER}', + }, + ], + } + +=attr previous_parent_group + +128-bit UUID identifying a group within the database. + +=attr quality_check + +Boolean indicating whether the entry password should be tested for weakness and show up in reports. + +=attr strings + +Hash with entry strings, including the standard strings as well as any custom ones. + + { + # Every entry has these five strings: + Title => { value => 'Example Entry' }, + UserName => { value => 'jdoe' }, + Password => { value => 's3cr3t', protect => true }, + URL => { value => 'https://example.com' } + Notes => { value => '' }, + # May also have custom strings: + MySystem => { value => 'The mainframe' }, + } + +=attr binaries + +Files or attachments. + +=attr custom_data + +A set of key-value pairs used to store arbitrary data, usually used by software to keep track of state rather +than by end users (who typically work with the strings and binaries). + +=attr history + +Array of historical entries. Historical entries are prior versions of the same entry so they all share the +same UUID with the current entry. + +=attr last_modification_time + +Date and time when the entry was last modified. + +=attr creation_time + +Date and time when the entry was created. + +=attr last_access_time + +Date and time when the entry was last accessed. + +=attr expiry_time + +Date and time when the entry expired or will expire. + +=attr expires + +Boolean value indicating whether or not an entry is expired. + +=attr usage_count + +The number of times an entry has been used, which typically means how many times the C<Password> string has +been accessed. + +=attr location_changed + +Date and time when the entry was last moved to a different group. + +=attr notes + +Alias for the C<Notes> string value. + +=attr password + +Alias for the C<Password> string value. + +=attr title + +Alias for the C<Title> string value. + +=attr url + +Alias for the C<URL> string value. + +=attr username + +Aliases for the C<UserName> string value. + +=cut + +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; + } + # if (defined $old_uuid and my $kdbx = $KDBX{refaddr($self)}) { + # $kdbx->_update_entry_uuid($old_uuid, $uuid, $self); + # } + } + $self->{uuid}; +} + +my @ATTRS = qw(uuid custom_data history); +my %ATTRS = ( + # uuid => sub { generate_uuid(printable => 1) }, + icon_id => ICON_PASSWORD, + custom_icon_uuid => undef, + foreground_color => '', + background_color => '', + override_url => '', + tags => '', + auto_type => sub { +{} }, + previous_parent_group => undef, + quality_check => true, + strings => sub { +{} }, + binaries => sub { +{} }, + # custom_data => sub { +{} }, + # history => sub { +[] }, +); +my %ATTRS_TIMES = ( + last_modification_time => sub { gmtime }, + creation_time => sub { gmtime }, + last_access_time => sub { gmtime }, + expiry_time => sub { gmtime }, + expires => false, + usage_count => 0, + location_changed => sub { gmtime }, +); +my %ATTRS_STRINGS = ( + title => 'Title', + username => 'UserName', + password => 'Password', + url => 'URL', + notes => 'Notes', +); + +while (my ($attr, $default) = each %ATTRS) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$attr} = sub { + my $self = shift; + $self->{$attr} = shift if @_; + $self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} +while (my ($attr, $default) = each %ATTRS_TIMES) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$attr} = sub { + my $self = shift; + $self->{times} //= {}; + $self->{times}{$attr} = shift if @_; + $self->{times}{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} +while (my ($attr, $string_key) = each %ATTRS_STRINGS) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$attr} = sub { shift->string_value($string_key, @_) }; + *{"expanded_${attr}"} = sub { shift->expanded_string_value($string_key, @_) }; +} + +sub _set_default_attributes { + my $self = shift; + $self->$_ for @ATTRS, keys %ATTRS, keys %ATTRS_TIMES, keys %ATTRS_STRINGS; +} + +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 label { shift->title(@_) } + +############################################################################## + +=method string + + \%string = $entry->string($string_key); + + $entry->string($string_key, \%string); + $entry->string($string_key, %attributes); + $entry->string($string_key, $value); # same as: value => $value + +Get or set a string. Every string has a unique (to the entry) key and flags and so are returned as a hash +structure. For example: + + $string = { + value => 'Password', + protect => true, + }; + +Every string should have a value and these optional flags which might exist: + +=for :list +* C<protect> - Whether or not the string value should be memory-protected. + +=cut + +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, @_) : @_; + + 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}); + + while (my ($field, $value) = each %args) { + $self->{strings}{$key}{$field} = $value; + } + + # Auto-vivify the standard strings. + if ($STANDARD_STRINGS{$key}) { + return $self->{strings}{$key} //= {value => '', $self->_protect($key) ? (protect => true) : ()}; + } + 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'; +} + +=method string_value + + $string = $entry->string_value; + +Access a string value directly. Returns C<undef> if the string is not set. + +=cut + +sub string_value { + my $self = shift; + my $string = $self->string(@_) // return undef; + return $string->{value}; +} + +=method expanded_string_value + + $string = $entry->expanded_string_value; + +Same as L</string_value> but will substitute placeholders and resolve field references. Any placeholders that +do not expand to values are left as-is. + +See L</Placeholders>. + +Some placeholders (notably field references) require the entry be associated with a database and will throw an +error if there is no association. + +=cut + +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('/', refaddr($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 expanded_string_value { + my $self = shift; + my $str = $self->string_value(@_) // return undef; + return $self->_expand_string($str); +} + +=method other_strings + + $other = $entry->other_strings; + $other = $entry->other_strings($delimiter); + +Get a concatenation of all non-standard string values. The default delimiter is a newline. This is is useful +for executing queries to search for entities based on the contents of these other strings (if any). + +=cut + +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 password_peek { $_[0]->string_peek('Password') } + +############################################################################## + +sub binary { + my $self = shift; + my $key = shift or throw 'Must provide a binary key to access'; + if (@_) { + my $arg = @_ == 1 ? shift : undef; + my %args; + @args{keys %$arg} = values %$arg if ref $arg eq 'HASH'; + $args{value} = $arg if !ref $arg; + while (my ($field, $value) = each %args) { + $self->{binaries}{$key}{$field} = $value; + } + } + my $binary = $self->{binaries}{$key} //= {value => ''}; + if (defined (my $ref = $binary->{ref})) { + $binary = $self->{binaries}{$key} = dclone($self->kdbx->binaries->{$ref}); + } + return $binary; +} + +sub binary_novivify { + my $self = shift; + my $binary_key = shift; + return if !$self->{binaries}{$binary_key} && !@_; + return $self->binary($binary_key, @_); +} + +sub binary_value { + my $self = shift; + my $binary = $self->binary_novivify(@_) // return undef; + return $binary->{value}; +} + +############################################################################## + +=method hmac_otp + + $otp = $entry->hmac_otp(%options); + +Generate an HMAC-based one-time password, or C<undef> if HOTP is not configured for the entry. The entry's +strings generally must first be unprotected, just like when accessing the password. Valid options are: + +=for :list +* C<counter> - Specify the counter value + +To configure HOTP, see L</"One-time Passwords">. + +=cut + +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; +} + +=method time_otp + + $otp = $entry->time_otp(%options); + +Generate a time-based one-time password, or C<undef> if TOTP is not configured for the entry. The entry's +strings generally must first be unprotected, just like when accessing the password. Valid options are: + +=for :list +* C<now> - Specify the value for determining the time-step counter + +To configure TOTP, see L</"One-time Passwords">. + +=cut + +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; +} + +=method hmac_otp_uri + +=method time_otp_uri + + $uri_string = $entry->hmac_otp_uri; + $uri_string = $entry->time_otp_uri; + +Get a HOTP or TOTP otpauth URI for the entry, if available. + +To configure OTP, see L</"One-time Passwords">. + +=cut + +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->title || 'KDBX', + account => $self->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->title || 'KDBX', + account => $self->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; +} + +############################################################################## + +=method size + + $size = $entry->size; + +Get the size (in bytes) of an entry. + +B<NOTE:> This is not an exact figure because there is no canonical serialization of an entry. This size should +only be used as a rough estimate for comparison with other entries or to impose data size limitations. + +=cut + +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; + return [map { __PACKAGE__->wrap($_, $self->kdbx) } @{$self->{history} || []}]; +} + +=method history_size + + $size = $entry->history_size; + +Get the size (in bytes) of all historical entries combined. + +=cut + +sub history_size { + my $self = shift; + return sum0 map { $_->size } @{$self->history}; +} + +=method prune_history + + $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>: + +=for :list +* C<max_items> - Maximum number of historical entries to keep (default: 10, no limit: -1) +* C<max_size> - Maximum total size (in bytes) of historical entries to keep (default: 6 MiB, no limit: -1) + +=cut + +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; + + # history is ordered oldest to youngest + my $history = $self->history; + + if (0 <= $max_items && $max_items < @$history) { + splice @$history, -$max_items; + } + + if (0 <= $max_size) { + my $current_size = $self->history_size; + while ($max_size < $current_size) { + my $entry = shift @$history; + $current_size -= $entry->size; + } + } +} + +sub add_history { + my $self = shift; + delete $_->{history} for @_; + push @{$self->{history} //= []}, @_; +} + +############################################################################## + +sub begin_work { + my $self = shift; + require File::KDBX::Transaction; + return File::KDBX::Transaction->new($self, @_); +} + +sub _commit { + my $self = shift; + my $txn = shift; + $self->add_history($txn->original); + $self->last_modification_time(gmtime); +} + +sub TO_JSON { +{%{$_[0]}} } + +1; +__END__ + +=head1 DESCRIPTION + +An entry in a KDBX database is a record that can contains strings (also called "fields") and binaries (also +called "files" or "attachments"). Every string and binary has a key or name. There is a default set of strings +that every entry has: + +=for :list +* C<Title> +* C<UserName> +* C<Password> +* C<URL> +* C<Notes> + +Beyond this, you can store any number of other strings and any number of binaries that you can use for +whatever purpose you want. + +There is also some metadata associated with an entry. Each entry in a database is identified uniquely by +a UUID. An entry can also have an icon associated with it, and there are various timestamps. Take a look at +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 +values. Placeholders can appear like C<{PLACEHOLDER}>. For example, a B<URL> string might have a value of +C<http://example.com?user={USERNAME}>. C<{USERNAME}> is a placeholder for the value of the B<UserName> string +of the same entry. If the C<UserName> string had a value of "batman", the B<URL> string would expand to +C<http://example.com?user=batman>. + +Some placeholders take an argument, where the argument follows the tag after a colon. The syntax for this is +C<{PLACEHOLDER:ARGUMENT}>. + +Placeholders are documented in the L<KeePass Help Center|https://keepass.info/help/base/placeholders.html>. +This software supports many (but not all) of the placeholders documented there. + +=head3 Entry Placeholders + +=for :list +* ☑ C<{TITLE}> - B<Title> string +* ☑ C<{USERNAME}> - B<UserName> string +* ☑ C<{PASSWORD}> - B<Password> string +* ☑ C<{NOTES}> - B<Notes> string +* ☑ C<{URL}> - B<URL> string +* ☑ C<{URL:SCM}> / C<{URL:SCHEME}> +* ☑ C<{URL:USERINFO}> +* ☑ C<{URL:USERNAME}> +* ☑ C<{URL:PASSWORD}> +* ☑ C<{URL:HOST}> +* ☑ C<{URL:PORT}> +* ☑ C<{URL:PATH}> +* ☑ C<{URL:QUERY}> +* ☑ C<{URL:FRAGMENT}> / C<{URL:HASH}> +* ☑ C<{URL:RMVSCM}> / C<{URL:WITHOUTSCHEME}> +* ☑ C<{S:Name}> - Custom string where C<Name> is the name or key of the string +* ☑ C<{UUID}> - Identifier (32 hexidecimal characters) +* ☑ C<{HMACOTP}> - Generate an HMAC-based one-time password +* ☑ 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 +* ☑ C<{GROUP}> - Name of the parent group + +=head3 Field References + +=for :list +* ☑ C<{REF:Wanted@SearchIn:Text}> - See L<File::KDBX/resolve_reference> + +=head3 File path Placeholders + +=for :list +* ☑ C<{APPDIR}> - Program directory path +* ☑ C<{FIREFOX}> - Path to the Firefox browser executable +* ☑ C<{GOOGLECHROME}> - Path to the Chrome browser executable +* ☑ C<{INTERNETEXPLORER}> - Path to the Firefox browser executable +* ☑ C<{OPERA}> - Path to the Opera browser executable +* ☑ C<{SAFARI}> - Path to the Safari browser executable +* ☒ C<{DB_PATH}> - Full file path of the database +* ☒ C<{DB_DIR}> - Directory path of the database +* ☒ C<{DB_NAME}> - File name (including extension) of the database +* ☒ C<{DB_BASENAME}> - File name (excluding extension) of the database +* ☒ C<{DB_EXT}> - File name extension +* ☑ C<{ENV_DIRSEP}> - Directory separator +* ☑ C<{ENV_PROGRAMFILES_X86}> - One of C<%ProgramFiles(x86)%> or C<%ProgramFiles%> + +=head3 Date and Time Placeholders + +=for :list +* ☑ C<{DT_SIMPLE}> - Current local date and time as a sortable string +* ☑ C<{DT_YEAR}> - Year component of the current local date +* ☑ C<{DT_MONTH}> - Month component of the current local date +* ☑ C<{DT_DAY}> - Day component of the current local date +* ☑ C<{DT_HOUR}> - Hour component of the current local time +* ☑ C<{DT_MINUTE}> - Minute component of the current local time +* ☑ C<{DT_SECOND}> - Second component of the current local time +* ☑ C<{DT_UTC_SIMPLE}> - Current UTC date and time as a sortable string +* ☑ C<{DT_UTC_YEAR}> - Year component of the current UTC date +* ☑ C<{DT_UTC_MONTH}> - Month component of the current UTC date +* ☑ C<{DT_UTC_DAY}> - Day component of the current UTC date +* ☑ C<{DT_UTC_HOUR}> - Hour component of the current UTC time +* ☑ C<{DT_UTC_MINUTE}> Minute Year component of the current UTC time +* ☑ C<{DT_UTC_SECOND}> - Second component of the current UTC time + +If the current date and time is <2012-07-25 17:05:34>, the "simple" form would be C<20120725170534>. + +=head3 Special Key Placeholders + +Certain placeholders for use in auto-type key sequences are not supported for replacement, but they will +remain as-is so that an auto-type engine (not included) can parse and replace them with the appropriate +virtual key presses. For completeness, here is the list that the KeePass program claims to support: + +C<{TAB}>, C<{ENTER}>, C<{UP}>, C<{DOWN}>, C<{LEFT}>, C<{RIGHT}>, C<{HOME}>, C<{END}>, C<{PGUP}>, C<{PGDN}>, +C<{INSERT}>, C<{DELETE}>, C<{SPACE}> + +C<{BACKSPACE}>, C<{BREAK}>, C<{CAPSLOCK}>, C<{ESC}>, C<{WIN}>, C<{LWIN}>, C<{RWIN}>, C<{APPS}>, C<{HELP}>, +C<{NUMLOCK}>, C<{PRTSC}>, C<{SCROLLLOCK}> + +C<{F1}>, C<{F2}>, C<{F3}>, C<{F4}>, C<{F5}>, C<{F6}>, C<{F7}>, C<{F8}>, C<{F9}>, C<{F10}>, C<{F11}>, C<{F12}>, +C<{F13}>, C<{F14}>, C<{F15}>, C<{F16}> + +C<{ADD}>, C<{SUBTRACT}>, C<{MULTIPLY}>, C<{DIVIDE}>, C<{NUMPAD0}>, C<{NUMPAD1}>, C<{NUMPAD2}>, C<{NUMPAD3}>, +C<{NUMPAD4}>, C<{NUMPAD5}>, C<{NUMPAD6}>, C<{NUMPAD7}>, C<{NUMPAD8}>, C<{NUMPAD9}> + +=head3 Miscellaneous Placeholders + +=for :list +* ☒ C<{BASE}> +* ☒ C<{BASE:SCM}> / C<{BASE:SCHEME}> +* ☒ C<{BASE:USERINFO}> +* ☒ C<{BASE:USERNAME}> +* ☒ C<{BASE:PASSWORD}> +* ☒ C<{BASE:HOST}> +* ☒ C<{BASE:PORT}> +* ☒ C<{BASE:PATH}> +* ☒ C<{BASE:QUERY}> +* ☒ C<{BASE:FRAGMENT}> / C<{BASE:HASH}> +* ☒ C<{BASE:RMVSCM}> / C<{BASE:WITHOUTSCHEME}> +* ☒ C<{CLIPBOARD-SET:/Text/}> +* ☒ C<{CLIPBOARD}> +* ☒ C<{CMD:/CommandLine/Options/}> +* ☑ C<{C:Comment}> - Comments are simply replaced by nothing +* ☑ C<{ENV:} and C<%ENV%> - Environment variables +* ☒ C<{GROUP_SEL_NOTES}> +* ☒ C<{GROUP_SEL_PATH}> +* ☒ C<{GROUP_SEL}> +* ☒ C<{NEWPASSWORD}> +* ☒ C<{NEWPASSWORD:/Profile/}> +* ☒ C<{PASSWORD_ENC}> +* ☒ C<{PICKCHARS}> +* ☒ C<{PICKCHARS:Field:Options}> +* ☒ C<{PICKFIELD}> +* ☒ C<{T-CONV:/Text/Type/}> +* ☒ C<{T-REPLACE-RX:/Text/Type/Replace/}> + +Some of these that remain unimplemented, such as C<{CLIPBOARD}>, cannot be implemented portably. Some of these +I haven't implemented (yet) just because they don't seem very useful. You can create your own placeholder to +augment the list of default supported placeholders or to replace a built-in placeholder handler. To create +a placeholder, just set it in the C<%File::KDBX::PLACEHOLDERS> hash. For example: + + $File::KDBX::PLACEHOLDERS{'MY_PLACEHOLDER'} = sub { + my ($entry) = @_; + ...; + }; + +If the placeholder is expanded in the context of an entry, C<$entry> is the B<File::KDBX::Entry> object in +context. Otherwise it is C<undef>. An entry is in context if, for example, the placeholder is in an entry's +strings or auto-complete key sequences. + + $File::KDBX::PLACEHOLDERS{'MY_PLACEHOLDER:'} = sub { + my ($entry, $arg) = @_; # ^ Notice the colon here + ...; + }; + +If the name of the placeholder ends in a colon, then it is expected to receive an argument. During expansion, +everything after the colon and before the end of the placeholder is passed to your placeholder handler +subroutine. So if the placeholder is C<{MY_PLACEHOLDER:whatever}>, C<$arg> will have the value C<whatever>. + +An argument is required for placeholders than take one. I.e. The placeholder handler won't be called if there +is no argument. If you want a placeholder to support an optional argument, you'll need to set the placeholder +both with and without a colon (or they could be different subroutines): + + $File::KDBX::PLACEHOLDERS{'RAND'} = $File::KDBX::PLACEHOLDERS{'RAND:'} = sub { + (undef, my $arg) = @_; + return defined $arg ? rand($arg) : rand; + }; + +You can also remove placeholder handlers. If you want to disable placeholder expansion entirely, just delete +all the handlers: + + %File::KDBX::PLACEHOLDERS = (); + +=head2 One-time Passwords + +An entry can be configured to generate one-time passwords, both HOTP (HMAC-based) and TOTP (time-based). The +configuration storage isn't completely standardized, but this module supports two predominant configuration +styles: + +=for :list +* L<KeePass 2|https://keepass.info/help/base/placeholders.html#otp> +* KeePassXC + +B<NOTE:> To use this feature, you must install the suggested dependency: + +=for :list +* L<Pass::OTP> + +To configure TOTP in the KeePassXC style, there is only one string to set: C<otp>. The value should be any +valid otpauth URI. When generating an OTP, all of the relevant OTP properties are parsed from the URI. + +To configure TOTP in the KeePass 2 style, set the following strings: + +=for :list +* C<TimeOtp-Algorithm> - Cryptographic algorithm, one of C<HMAC-SHA-1> (default), C<HMAC-SHA-256> and + C<HMAC-SHA-512> +* C<TimeOtp-Length> - Number of digits each one-time password is (default: 6, maximum: 8) +* C<TimeOtp-Period> - Time-step size in seconds (default: 30) +* C<TimeOtp-Secret> - Text string secret, OR +* C<TimeOtp-Secret-Hex> - Hexidecimal-encoded secret, OR +* C<TimeOtp-Secret-Base32> - Base32-encoded secret (most common), OR +* C<TimeOtp-Secret-Base64> - Base64-encoded secret + +To configure HOTP in the KeePass 2 style, set the following strings: + +=for :list +* C<HmacOtp-Counter> - Counting value in decimal, starts on C<0> by default and increments when L</hmac_otp> + is called +* C<HmacOtp-Secret> - Text string secret, OR +* C<HmacOtp-Secret-Hex> - Hexidecimal-encoded secret, OR +* C<HmacOtp-Secret-Base32> - Base32-encoded secret (most common), OR +* C<HmacOtp-Secret-Base64> - Base64-encoded secret + +B<NOTE:> The multiple "Secret" strings are simply a way to store a secret in different formats. Only one of +these should actually be set or an error will be thrown. + +Here's a basic example: + + $entry->string(otp => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer'); + # OR + $entry->string('TimeOtp-Secret-Base32' => 'NBSWY3DP'); + + my $otp = $entry->time_otp; + +=cut diff --git a/lib/File/KDBX/Error.pm b/lib/File/KDBX/Error.pm new file mode 100644 index 0000000..f801557 --- /dev/null +++ b/lib/File/KDBX/Error.pm @@ -0,0 +1,221 @@ +package File::KDBX::Error; +# ABSTRACT: Represents something bad that happened + +use warnings; +use strict; + +use Exporter qw(import); +use Scalar::Util qw(blessed); +use namespace::clean -except => 'import'; + +our $VERSION = '999.999'; # VERSION + +our @EXPORT = qw(alert error throw); + +my $WARNINGS_CATEGORY; +BEGIN { + $WARNINGS_CATEGORY = 'File::KDBX'; + warnings::register_categories($WARNINGS_CATEGORY) if warnings->can('register_categories'); +} + +use overload '""' => 'to_string', cmp => '_cmp'; + +=method new + + $error = File::KDBX::Error->new($message, %details); + +Construct a new error. + +=cut + +sub new { + my $class = shift; + my %args = @_ % 2 == 0 ? @_ : (_error => shift, @_); + + my $error = delete $args{_error}; + my $e = $error; + # $e =~ s/ at \H+ line \d+.*//g; + + my $self = bless { + details => \%args, + error => $e // 'Something happened', + errno => $!, + previous => $@, + trace => do { + require Carp; + local $Carp::CarpInternal{''.__PACKAGE__} = 1; + my $mess = $error =~ /at \H+ line \d+/ ? $error : Carp::longmess($error); + [map { /^\h*(.*?)\.?$/ ? $1 : $_ } split(/\n/, $mess)]; + }, + }, $class; + chomp $self->{error}; + return $self; +} + +=method error + + $error = error($error); + $error = error($message, %details); + $error = File::KDBX::Error->error($error); + $error = File::KDBX::Error->error($message, %details); + +Wrap a thing to make it an error object. If the thing is already an error, it gets returned. Otherwise what is +passed will be forwarded to L</new> to create a new error object. + +This can be convenient for error handling when you're not sure what the exception is but you want to treat it +as a B<File::KDBX::Error>. Example: + + eval { .... }; + if (my $error = error(@_)) { + if ($error->type eq 'key.missing') { + handle_missing_key($error); + } + else { + handle_other_error($error); + } + } + +=cut + +sub error { + my $self = (blessed($_[0]) && $_[0]->isa('File::KDBX::Error')) + ? shift + : (@_ && $_[0] eq __PACKAGE__) + ? shift->new(@_) + : __PACKAGE__->new(@_); + return $self; +} + +=attr details + + \%details = $error->details; + +Get the error details. + +=cut + +sub details { + my $self = shift; + my %args = @_; + my $details = $self->{details} //= {}; + @$details{keys %args} = values %args; + return $details; +} + +sub errno { $_[0]->{errno} } + +sub previous { $_[0]->{previous} } + +sub trace { $_[0]->{trace} // [] } + +sub type { $_[0]->details->{type} // '' } + +=method to_string + + $message = $error->to_string; + $message = "$error"; + +Stringify an error. + +This does not contain a stack trace, but you can set the C<DEBUG> environment +variable to truthy to stringify the whole error object. + +=cut + +sub _cmp { "$_[0]" cmp "$_[1]" } + +sub PROPAGATE { + 'wat'; +} + +sub to_string { + my $self = shift; + # return "uh oh\n"; + my $msg = "$self->{trace}[0]"; + $msg .= '.' if $msg !~ /[\.\!\?]$/; # Why does this cause infinite recursion on some perls? + # $msg .= '.' if $msg !~ /(?:\.|!|\?)$/; + if ($ENV{DEBUG}) { + require Data::Dumper; + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Trailingcomma = 1; + local $Data::Dumper::Useqq = 1; + $msg .= "\n" . Data::Dumper::Dumper $self; + } + $msg .= "\n" if $msg !~ /\n$/; + return $msg; +} + +=method throw + + File::KDBX::Error::throw($message, %details); + $error->throw; + +Throw an error. + +=cut + +sub throw { + my $self = error(@_); + die $self; +} + +=method warn + + File::KDBX::Error::warn($message, %details); + $error->warn; + +Log a warning. + +=cut + +sub warn { + return if !($File::KDBX::WARNINGS // 1); + + my $self = error(@_); + + # Use die and warn directly instead of warnings::warnif because the latter only provides the stringified + # error to the warning signal handler (perl 5.34). Maybe that's a warnings.pm bug? + + if (my $fatal = warnings->can('fatal_enabled_at_level')) { + my $blame = _find_blame_frame(); + die $self if $fatal->($WARNINGS_CATEGORY, $blame); + } + + if (my $enabled = warnings->can('enabled_at_level')) { + my $blame = _find_blame_frame(); + warn $self if $enabled->($WARNINGS_CATEGORY, $blame); + } + elsif ($enabled = warnings->can('enabled')) { + warn $self if $enabled->($WARNINGS_CATEGORY); + } + else { + warn $self; + } + return $self; +} + +=method alert + + alert $error; + +Importable alias for L</warn>. + +=cut + +sub alert { goto &warn } + +sub _find_blame_frame { + my $frame = 1; + while (1) { + my ($package) = caller($frame); + last if !$package; + return $frame - 1 if $package !~ /^\Q$WARNINGS_CATEGORY\E/; + $frame++; + } + return 0; +} + +1; diff --git a/lib/File/KDBX/Group.pm b/lib/File/KDBX/Group.pm new file mode 100644 index 0000000..733e931 --- /dev/null +++ b/lib/File/KDBX/Group.pm @@ -0,0 +1,249 @@ +package File::KDBX::Group; +# ABSTRACT: A KDBX database group + +use warnings; +use strict; + +use Devel::GlobalDestruction; +use File::KDBX::Constants qw(:icon); +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 Time::Piece; +use boolean; +use namespace::clean; + +use parent 'File::KDBX::Object'; + +our $VERSION = '999.999'; # VERSION + +my @ATTRS = qw(uuid custom_data entries groups); +my %ATTRS = ( + # uuid => sub { generate_uuid(printable => 1) }, + name => '', + notes => '', + tags => '', + icon_id => ICON_FOLDER, + custom_icon_uuid => undef, + is_expanded => false, + default_auto_type_sequence => '', + enable_auto_type => undef, + enable_searching => undef, + last_top_visible_entry => undef, + # custom_data => sub { +{} }, + previous_parent_group => undef, + # entries => sub { +[] }, + # groups => sub { +[] }, +); +my %ATTRS_TIMES = ( + last_modification_time => sub { gmtime }, + creation_time => sub { gmtime }, + last_access_time => sub { gmtime }, + expiry_time => sub { gmtime }, + expires => false, + usage_count => 0, + location_changed => sub { gmtime }, +); + +while (my ($attr, $default) = each %ATTRS) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$attr} = sub { + my $self = shift; + $self->{$attr} = shift if @_; + $self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} +while (my ($attr, $default) = each %ATTRS_TIMES) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$attr} = sub { + my $self = shift; + $self->{times}{$attr} = shift if @_; + $self->{times}{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} + +sub _set_default_attributes { + my $self = shift; + $self->$_ for @ATTRS, keys %ATTRS, keys %ATTRS_TIMES; +} + +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; + # if (defined $old_uuid and my $kdbx = $KDBX{refaddr($self)}) { + # $kdbx->_update_group_uuid($old_uuid, $uuid, $self); + # } + } + $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; + return $entries; +} + +sub groups { + my $self = shift; + my $groups = $self->{groups} //= []; + @$groups = map { File::KDBX::Group->wrap($_, $self->kdbx) } @$groups; + return $groups; +} + +sub _kpx_groups { shift->groups(@_) } + +sub all_groups { + my $self = shift; + return $self->kdbx->all_groups(base => $self, include_base => false); +} + +sub all_entries { + my $self = shift; + return $self->kdbx->all_entries(base => $self); +} + +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 add_entry { + my $self = shift; + my $entry = shift; + push @{$self->{entries} ||= []}, $entry; + return $entry; +} + +sub add_group { + my $self = shift; + my $group = shift; + push @{$self->{groups} ||= []}, $group; + return $group; +} + +sub add_object { + my $self = shift; + my $obj = shift; + if ($obj->isa('File::KDBX::Entry')) { + $self->add_entry($obj); + } + elsif ($obj->isa('File::KDBX::Group')) { + $self->add_group($obj); + } +} + +sub remove_object { + my $self = shift; + my $object = shift; + my $blessed = blessed($object); + return $self->remove_group($object, @_) if $blessed && $object->isa('File::KDBX::Group'); + return $self->remove_entry($object, @_) if $blessed && $object->isa('File::KDBX::Entry'); + 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 { + 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; + } +} + +sub path { + my $self = shift; + my $lineage = $self->kdbx->trace_lineage($self) or return; + return join('.', map { $_->name } @$lineage); +} + +sub size { + my $self = shift; + return sum0 map { $_->size } @{$self->groups}, @{$self->entries}; +} + +sub level { $_[0]->kdbx->group_level($_[0]) } + +sub TO_JSON { +{%{$_[0]}} } + +1; +__END__ + +=head1 DESCRIPTION + +=attr uuid + +=attr name + +=attr notes + +=attr tags + +=attr icon_id + +=attr custom_icon_uuid + +=attr is_expanded + +=attr default_auto_type_sequence + +=attr enable_auto_type + +=attr enable_searching + +=attr last_top_visible_entry + +=attr custom_data + +=attr previous_parent_group + +=attr entries + +=attr groups + +=attr last_modification_time + +=attr creation_time + +=attr last_access_time + +=attr expiry_time + +=attr expires + +=attr usage_count + +=attr location_changed + +Get or set various group fields. + +=cut diff --git a/lib/File/KDBX/KDF.pm b/lib/File/KDBX/KDF.pm new file mode 100644 index 0000000..c447cc0 --- /dev/null +++ b/lib/File/KDBX/KDF.pm @@ -0,0 +1,205 @@ +package File::KDBX::KDF; +# ABSTRACT: A key derivation function + +use warnings; +use strict; + +use Crypt::PRNG qw(random_bytes); +use File::KDBX::Constants qw(:version :kdf); +use File::KDBX::Error; +use File::KDBX::Util qw(format_uuid); +use Module::Load; +use Scalar::Util qw(blessed); +use namespace::clean; + +our $VERSION = '999.999'; # VERSION + +my %KDFS; + +=method new + + $kdf = File::KDBX::KDF->new(parameters => \%params); + +Construct a new KDF. + +=cut + +sub new { + my $class = shift; + my %args = @_; + + my $uuid = $args{+KDF_PARAM_UUID} //= delete $args{uuid} or throw 'Missing KDF UUID', args => \%args; + my $formatted_uuid = format_uuid($uuid); + + my $kdf = $KDFS{$uuid} or throw "Unsupported KDF ($formatted_uuid)", uuid => $uuid; + ($class, my %registration_args) = @$kdf; + + load $class; + my $self = bless {KDF_PARAM_UUID() => $uuid}, $class; + return $self->init(%args, %registration_args); +} + +sub init { + my $self = shift; + my %args = @_; + + @$self{keys %args} = values %args; + + return $self; +} + +=attr uuid + + $uuid => $kdf->uuid; + +Get the UUID used to determine which function to use. + +=cut + +sub uuid { $_[0]->{+KDF_PARAM_UUID} } + +=attr seed + + $seed = $kdf->seed; + +Get the seed (or salt, depending on the function). + +=cut + +sub seed { die "Not implemented" } + +=method transform + + $transformed_key = $kdf->transform($key); + $transformed_key = $kdf->transform($key, $challenge); + +Transform a key. The input key can be either a L<File::KDBX::Key> or a raw binary key, and the +transformed key will be a raw key. + +This can take awhile, depending on the KDF parameters. + +If a challenge is provided (and the KDF is AES except for the KeePassXC variant), it will be passed to the key +so challenge-response keys can produce raw keys. See L<File::KDBX::Key/raw_key>. + +=cut + +sub transform { + my $self = shift; + my $key = shift; + + if (blessed $key && $key->can('raw_key')) { + return $self->_transform($key->raw_key) if $self->uuid eq KDF_UUID_AES; + return $self->_transform($key->raw_key($self->seed, @_)); + } + + return $self->_transform($key); +} + +sub _transform { die "Not implemented" } + +=method randomize_seed + + $kdf->randomize_seed; + +Generate a new random seed/salt. + +=cut + +sub randomize_seed { + my $self = shift; + $self->{+KDF_PARAM_AES_SEED} = random_bytes(length($self->seed)); +} + +=method register + + File::KDBX::KDF->register($uuid => $package, %args); + +Register a KDF. Registered KDFs can be used to encrypt and decrypt KDBX databases. A KDF's UUID B<must> be +unique and B<musn't change>. A KDF UUID is written into each KDBX file and the associated KDF must be +registered with the same UUID in order to decrypt the KDBX file. + +C<$package> should be a Perl package relative to C<File::KDBX::KDF::> or prefixed with a C<+> if it is +a fully-qualified package. C<%args> are passed as-is to the KDF's L</init> method. + +=cut + +sub register { + my $class = shift; + my $id = shift; + my $package = shift; + my @args = @_; + + my $formatted_id = format_uuid($id); + $package = "${class}::${package}" if $package !~ s/^\+// && $package !~ /^\Q${class}::\E/; + + my %blacklist = map { File::KDBX::Util::uuid($_) => 1 } split(/,/, $ENV{FILE_KDBX_KDF_BLACKLIST} // ''); + if ($blacklist{$id} || $blacklist{$package}) { + alert "Ignoring blacklisted KDF ($formatted_id)", id => $id, package => $package; + return; + } + + if (defined $KDFS{$id}) { + alert "Overriding already-registered KDF ($formatted_id) with package $package", + id => $id, + package => $package; + } + + $KDFS{$id} = [$package, @args]; +} + +=method unregister + + File::KDBX::KDF->unregister($uuid); + +Unregister a KDF. Unregistered KDFs can no longer be used to encrypt and decrypt KDBX databases, until +reregistered (see L</register>). + +=cut + +sub unregister { + delete $KDFS{$_} for @_; +} + +BEGIN { + __PACKAGE__->register(KDF_UUID_AES, 'AES'); + __PACKAGE__->register(KDF_UUID_AES_CHALLENGE_RESPONSE, 'AES'); + __PACKAGE__->register(KDF_UUID_ARGON2D, 'Argon2'); + __PACKAGE__->register(KDF_UUID_ARGON2ID, 'Argon2'); +} + +1; +__END__ + +=head1 DESCRIPTION + +A KDF (key derivation function) is used in the transformation of a master key (i.e. one or more component +keys) to produce the final encryption key protecting a KDBX database. The L<File::KDBX> distribution comes +with several pre-registered KDFs ready to go: + +=for :list +* C<C9D9F39A-628A-4460-BF74-0D08C18A4FEA> - AES +* C<7C02BB82-79A7-4AC0-927D-114A00648238> - AES (challenge-response variant) +* C<EF636DDF-8C29-444B-91F7-A9A403E30A0C> - Argon2d +* C<9E298B19-56DB-4773-B23D-FC3EC6F0A1E6> - Argon2id + +B<NOTE:> If you want your KDBX file to be readable by other KeePass implementations, you must use a UUID and +algorithm that they support. From the list above, all are well-supported except the AES challenge-response +variant which is kind of a pseudo KDF and isn't usually written into files. All of these are good. AES has +a longer track record, but Argon2 has better ASIC resistance. + +You can also L</register> your own KDF. Here is a skeleton: + + package File::KDBX::KDF::MyKDF; + + use parent 'File::KDBX::KDF'; + + File::KDBX::KDF->register( + # $uuid, $package, %args + "\x12\x34\x56\x78\x9a\xbc\xde\xfg\x12\x34\x56\x78\x9a\xbc\xde\xfg" => __PACKAGE__, + ); + + sub init { ... } # optional + + sub _transform { my ($key) = @_; ... } + +=cut diff --git a/lib/File/KDBX/KDF/AES.pm b/lib/File/KDBX/KDF/AES.pm new file mode 100644 index 0000000..8ee1340 --- /dev/null +++ b/lib/File/KDBX/KDF/AES.pm @@ -0,0 +1,123 @@ +package File::KDBX::KDF::AES; +# ABSTRACT: Using the AES cipher as a key derivation function + +use warnings; +use strict; + +use Crypt::Cipher; +use Crypt::Digest qw(digest_data); +use File::KDBX::Constants qw(:kdf); +use File::KDBX::Error; +use File::KDBX::Util qw(:load can_fork); +use namespace::clean; + +use parent 'File::KDBX::KDF'; + +our $VERSION = '999.999'; # VERSION + +# Rounds higher than this are eligible for forking: +my $FORK_OPTIMIZATION_THRESHOLD = 100_000; + +BEGIN { + load_xs; + + my $use_fork = 1; + $use_fork = 0 if $ENV{NO_FORK} || !can_fork; + *USE_FORK = $use_fork ? sub() { 1 } : sub() { 0 }; +} + +sub init { + my $self = shift; + my %args = @_; + return $self->SUPER::init( + KDF_PARAM_AES_ROUNDS() => $args{+KDF_PARAM_AES_ROUNDS} // $args{rounds}, + KDF_PARAM_AES_SEED() => $args{+KDF_PARAM_AES_SEED} // $args{seed}, + ); +} + +=attr rounds + + $rounds = $kdf->rounds; + +Get the number of times to run the function during transformation. + +=cut + +sub rounds { $_[0]->{+KDF_PARAM_AES_ROUNDS} || KDF_DEFAULT_AES_ROUNDS } +sub seed { $_[0]->{+KDF_PARAM_AES_SEED} } + +sub _transform { + my $self = shift; + my $key = shift; + + my $seed = $self->seed; + my $rounds = $self->rounds; + + length($key) == 32 or throw 'Raw key must be 32 bytes', size => length($key); + length($seed) == 32 or throw 'Invalid seed length', size => length($seed); + + my ($key_l, $key_r) = unpack('(a16)2', $key); + + 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 + my $l = _transform_half($seed, $key_l, $rounds); + require POSIX; + print $l or POSIX::_exit(1); + POSIX::_exit(0); + } + my $r = _transform_half($seed, $key_r, $rounds); + read($read, my $l, length($key_l)) == length($key_l) or do { alert "read failed: $!", goto NO_FORK }; + close($read) or do { alert "worker thread exited abnormally", status => $?; goto NO_FORK }; + return digest_data('SHA256', $l, $r); + } + + # FIXME: This used to work but now it crashes frequently. threads are discouraged anyway + # 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); + # return digest_data('SHA256', $l->join, $r); + # } + + NO_FORK: + my $l = _transform_half($seed, $key_l, $rounds); + my $r = _transform_half($seed, $key_r, $rounds); + return digest_data('SHA256', $l, $r); +} + +sub _transform_half { + my $xs = __PACKAGE__->can('_transform_half_xs'); + goto $xs if $xs; + + my $seed = shift; + my $key = shift; + my $rounds = shift; + + my $c = Crypt::Cipher->new('AES', $seed); + + my $result = $key; + for (my $i = 0; $i < $rounds; ++$i) { + $result = $c->encrypt($result); + } + + return $result; +} + +1; +__END__ + +=head1 DESCRIPTION + +An AES-256-based key derivation function. This is a L<File::KDBX::KDF> subclass. + +This KDF has a long, solid track record. It is supported in both KDBX3 and KDBX4. + +=head1 CAVEATS + +This module can be pretty slow when the number of rounds is high. If you have L<File::KDBX::XS>, that will +help. If your perl has C<fork>, that will also help. If you need to turn off one or both of these +optimizations for some reason, set the C<PERL_ONLY> (to prevent Loading C<File::KDBX::XS>) and C<NO_FORK> +environment variables. + +=cut diff --git a/lib/File/KDBX/KDF/Argon2.pm b/lib/File/KDBX/KDF/Argon2.pm new file mode 100644 index 0000000..6019380 --- /dev/null +++ b/lib/File/KDBX/KDF/Argon2.pm @@ -0,0 +1,87 @@ +package File::KDBX::KDF::Argon2; +# ABSTRACT: The Argon2 family of key derivation functions + +use warnings; +use strict; + +use Crypt::Argon2 qw(argon2d_raw argon2id_raw); +use File::KDBX::Constants qw(:kdf); +use File::KDBX::Error; +use namespace::clean; + +use parent 'File::KDBX::KDF'; + +our $VERSION = '999.999'; # VERSION + +sub init { + my $self = shift; + my %args = @_; + return $self->SUPER::init( + KDF_PARAM_ARGON2_SALT() => $args{+KDF_PARAM_ARGON2_SALT} // $args{salt}, + KDF_PARAM_ARGON2_PARALLELISM() => $args{+KDF_PARAM_ARGON2_PARALLELISM} // $args{parallelism}, + KDF_PARAM_ARGON2_MEMORY() => $args{+KDF_PARAM_ARGON2_MEMORY} // $args{memory}, + KDF_PARAM_ARGON2_ITERATIONS() => $args{+KDF_PARAM_ARGON2_ITERATIONS} // $args{iterations}, + KDF_PARAM_ARGON2_VERSION() => $args{+KDF_PARAM_ARGON2_VERSION} // $args{version}, + KDF_PARAM_ARGON2_SECRET() => $args{+KDF_PARAM_ARGON2_SECRET} // $args{secret}, + KDF_PARAM_ARGON2_ASSOCDATA() => $args{+KDF_PARAM_ARGON2_ASSOCDATA} // $args{assocdata}, + ); +} + +=attr salt + +=attr parallelism + +=attr memory + +=attr iterations + +=attr version + +=attr secret + +=attr assocdata + +Get various KDF parameters. + +C<version>, C<secret> and C<assocdata> are currently unused. + +=cut + +sub salt { $_[0]->{+KDF_PARAM_ARGON2_SALT} or throw 'Salt is not set' } +sub parallelism { $_[0]->{+KDF_PARAM_ARGON2_PARALLELISM} //= KDF_DEFAULT_ARGON2_PARALLELISM } +sub memory { $_[0]->{+KDF_PARAM_ARGON2_MEMORY} //= KDF_DEFAULT_ARGON2_MEMORY } +sub iterations { $_[0]->{+KDF_PARAM_ARGON2_ITERATIONS} //= KDF_DEFAULT_ARGON2_ITERATIONS } +sub version { $_[0]->{+KDF_PARAM_ARGON2_VERSION} //= KDF_DEFAULT_ARGON2_VERSION } +sub secret { $_[0]->{+KDF_PARAM_ARGON2_SECRET} } +sub assocdata { $_[0]->{+KDF_PARAM_ARGON2_ASSOCDATA} } + +sub seed { $_[0]->salt } + +sub _transform { + my $self = shift; + my $key = shift; + + my ($uuid, $salt, $iterations, $memory, $parallelism) + = ($self->uuid, $self->salt, $self->iterations, $self->memory, $self->parallelism); + + if ($uuid eq KDF_UUID_ARGON2D) { + return argon2d_raw($key, $salt, $iterations, $memory, $parallelism, length($salt)); + } + elsif ($uuid eq KDF_UUID_ARGON2ID) { + return argon2id_raw($key, $salt, $iterations, $memory, $parallelism, length($salt)); + } + + throw 'Unknown Argon2 type', uuid => $uuid; +} + +1; +__END__ + +=head1 DESCRIPTION + +An Argon2 key derivation function. This is a L<File::KDBX::KDF> subclass. + +This KDF allows for excellent resistance to ASIC password cracking. It's a solid choice but doesn't have the +track record of L<File::KDBX::KDF::AES> and requires using the KDBX4+ file format. + +=cut diff --git a/lib/File/KDBX/Key.pm b/lib/File/KDBX/Key.pm new file mode 100644 index 0000000..e7ac888 --- /dev/null +++ b/lib/File/KDBX/Key.pm @@ -0,0 +1,232 @@ +package File::KDBX::Key; +# ABSTRACT: A credential that can protect a KDBX file + +use warnings; +use strict; + +use Devel::GlobalDestruction; +use File::KDBX::Error; +use File::KDBX::Safe; +use File::KDBX::Util qw(erase); +use Module::Load; +use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_scalarref); +use Scalar::Util qw(blessed openhandle refaddr); +use namespace::clean; + +our $VERSION = '999.999'; # VERSION + +my %SAFE; + +=method new + + $key = File::KDBX::Key->new({ password => $password }); + $key = File::KDBX::Key->new($password); + + $key = File::KDBX::Key->new({ file => $filepath }); + $key = File::KDBX::Key->new(\$file); + $key = File::KDBX::Key->new(\*FILE); + + $key = File::KDBX::Key->new({ composite => [...] }); + $key = File::KDBX::Key->new([...]); # composite key + + $key = File::KDBX::Key->new({ responder => \&responder }); + $key = File::KDBX::Key->new(\&responder); # challenge-response key + +Construct a new key. + +The primitive used to construct the key is not saved but is immediately converted to a raw encryption key (see +L</raw_key>). + +A L<File::KDBX::Key::Composite> is somewhat special in that it does retain a reference to its component keys, +and its raw key is calculated from its components on demand. + +=cut + +sub new { + my $class = shift; + my %args = @_ % 2 == 1 ? (primitive => shift, @_) : @_; + + my $primitive = $args{primitive}; + delete $args{primitive} if !$args{keep_primitive}; + return $primitive->hide if blessed $primitive && $primitive->isa($class); + + my $self = bless \%args, $class; + return $self->init($primitive) if defined $primitive; + return $self; +} + +sub DESTROY { !in_global_destruction and do { $_[0]->_clear_raw_key; erase \$_[0]->{primitive} } } + +=method init + + $key = $key->init($primitive); + +Initialize a L<File::KDBX::Key> with a new primitive. Returns itself to allow method chaining. + +=cut + +sub init { + my $self = shift; + my $primitive = shift // throw 'Missing key primitive'; + + my $pkg; + + if (is_arrayref($primitive)) { + $pkg = __PACKAGE__.'::Composite'; + } + elsif (is_scalarref($primitive) || openhandle($primitive)) { + $pkg = __PACKAGE__.'::File'; + } + elsif (is_coderef($primitive)) { + $pkg = __PACKAGE__.'::ChallengeResponse'; + } + elsif (!is_ref($primitive)) { + $pkg = __PACKAGE__.'::Password'; + } + elsif (is_hashref($primitive) && defined $primitive->{composite}) { + $pkg = __PACKAGE__.'::Composite'; + $primitive = $primitive->{composite}; + } + elsif (is_hashref($primitive) && defined $primitive->{password}) { + $pkg = __PACKAGE__.'::Password'; + $primitive = $primitive->{password}; + } + elsif (is_hashref($primitive) && defined $primitive->{file}) { + $pkg = __PACKAGE__.'::File'; + $primitive = $primitive->{file}; + } + elsif (is_hashref($primitive) && defined $primitive->{responder}) { + $pkg = __PACKAGE__.'::ChallengeResponse'; + $primitive = $primitive->{responder}; + } + else { + throw 'Invalid key primitive', primitive => $primitive; + } + + load $pkg; + bless $self, $pkg; + return $self->init($primitive); +} + +=method reload + + $key = $key->reload; + +Reload a key by re-reading the key source and recalculating the raw key. Returns itself to allow method +chaining. + +=cut + +sub reload { $_[0] } + +=method raw_key + + $raw_key = $key->raw_key; + $raw_key = $key->raw_key($challenge); + +Get the raw encryption key. This is calculated based on the primitive(s). The C<$challenge> argument is for +challenge-response type keys and is ignored by other types. + +B<NOTE:> The raw key is sensitive information and so is memory-protected while not being accessed. If you +access it, you should L<File::KDBX::Util/erase> it when you're done. + +=cut + +sub raw_key { + my $self = shift; + return $self->{raw_key} if !$self->is_hidden; + return $self->_safe->peek(\$self->{raw_key}); +} + +sub _set_raw_key { + my $self = shift; + $self->_clear_raw_key; + $self->{raw_key} = shift; # after clear + $self->_new_safe->add(\$self->{raw_key}); # auto-hide +} + +sub _clear_raw_key { + my $self = shift; + my $safe = $self->_safe; + $safe->clear if $safe; + erase \$self->{raw_key}; +} + +=method hide + + $key = $key->hide; + +Encrypt the raw key for L<File::KDBX/"Memory Protection>. Returns itself to allow method chaining. + +=cut + +sub hide { + my $self = shift; + $self->_new_safe->add(\$self->{raw_key}) if defined $self->{raw_key}; + return $self; +} + +=method show + + $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</raw_key> calls this implicitly. + +=cut + +sub show { + my $self = shift; + my $safe = $self->_safe; + $safe->unlock if $safe; + return $self; +} + +sub is_hidden { !!$SAFE{refaddr($_[0])} } + +# sub show_scoped { +# my $self = shift; +# require Scope::Guard; +# $self- +# return +# } + +sub _safe { $SAFE{refaddr($_[0])} } +sub _new_safe { $SAFE{refaddr($_[0])} = File::KDBX::Safe->new } + +1; +__END__ + +=head1 DESCRIPTION + +A master key is one or more credentials that can protect a KDBX database. When you encrypt a database with +a master key, you will need the master key to decrypt it. B<Keep your master key safe!> If someone gains +access to your master key, they can open your database. If you forget or lose any part of your master key, all +data in the database is lost. + +There are several different types of keys, each implemented as a subclass: + +=for :list +* L<File::KDBX::Key::Password> - Password or passphrase, knowledge of a string of characters +* L<File::KDBX::Key::File> - Possession of a file ("key file") with a secret. +* L<File::KDBX::Key::ChallengeResponse> - Possession of a device that responds correctly when challenged +* L<File::KDBX::Key::YubiKey> - Possession of a YubiKey hardware device (a type of challenge-response) +* L<File::KDBX::Key::Composite> - One or more keys combined as one + +A good master key is produced from a high amount of "entropy" (unpredictability). The more entropy the better. +Combining multiple keys into a B<Composite> key combines the entropy of each individual key. For example, if +you have a weak password and you combine it with other keys, the composite key is stronger than the weak +password key by itself. (Of course it's much better to not have any weak components of your master key.) + +B<COMPATIBILITY NOTE:> Most KeePass implementations are limited in the types and numbers of keys they support. +B<Password> keys are pretty much universally supported. B<File> keys are pretty well-supported. Many do not +support challenge-response keys. If you are concerned about compatibility, you should stick with one of these +configurations: + +=for :list +* One password +* One key file +* One password and one key file + +=cut diff --git a/lib/File/KDBX/Key/ChallengeResponse.pm b/lib/File/KDBX/Key/ChallengeResponse.pm new file mode 100644 index 0000000..b17a35c --- /dev/null +++ b/lib/File/KDBX/Key/ChallengeResponse.pm @@ -0,0 +1,61 @@ +package File::KDBX::Key::ChallengeResponse; +# ABSTRACT: A challenge-response key + +use warnings; +use strict; + +use File::KDBX::Error; +use namespace::clean; + +use parent 'File::KDBX::Key'; + +our $VERSION = '999.999'; # VERSION + +sub init { + my $self = shift; + my $primitive = shift or throw 'Missing key primitive'; + + $self->{responder} = $primitive; + + return $self->hide; +} + +sub raw_key { + my $self = shift; + if (@_) { + my $challenge = shift // ''; + # Don't challenge if we already have the response. + return $self->SUPER::raw_key if $challenge eq ($self->{challenge} // ''); + $self->_set_raw_key($self->challenge($challenge, @_)); + $self->{challenge} = $challenge; + } + $self->SUPER::raw_key; +} + +=method challenge + + $response = $key->challenge($challenge, @options); + +Issue a challenge and get a response, or throw if the responder failed. + +=cut + +sub challenge { + my $self = shift; + + my $responder = $self->{responder} or throw 'Cannot issue challenge without a responder'; + return $responder->(@_); +} + +1; +__END__ + +=head1 SYNOPSIS + + my $key = File::KDBX::Key::ChallengeResponse->( + responder => sub { my $challenge = shift; ...; return $response }, + ); + +=head1 DESCRIPTION + +=cut diff --git a/lib/File/KDBX/Key/Composite.pm b/lib/File/KDBX/Key/Composite.pm new file mode 100644 index 0000000..cd97314 --- /dev/null +++ b/lib/File/KDBX/Key/Composite.pm @@ -0,0 +1,87 @@ +package File::KDBX::Key::Composite; +# ABSTRACT: A composite key made up of component keys + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use File::KDBX::Error; +use File::KDBX::Util qw(:erase); +use Ref::Util qw(is_arrayref); +use Scalar::Util qw(blessed); +use namespace::clean; + +use parent 'File::KDBX::Key'; + +our $VERSION = '999.999'; # VERSION + +sub init { + my $self = shift; + my $primitive = shift // throw 'Missing key primitive'; + + my @primitive = grep { defined } is_arrayref($primitive) ? @$primitive : $primitive; + @primitive or throw 'Composite key must have at least one component key', count => scalar @primitive; + + my @keys = map { blessed $_ && $_->can('raw_key') ? $_ : File::KDBX::Key->new($_, + keep_primitive => $self->{keep_primitive}) } @primitive; + $self->{keys} = \@keys; + + return $self->hide; +} + +sub raw_key { + my $self = shift; + my $challenge = shift; + + my @keys = @{$self->keys} or throw 'Cannot generate a raw key from an empty composite key'; + + my @basic_keys = map { $_->raw_key } grep { !$_->can('challenge') } @keys; + my $response; + $response = $self->challenge($challenge, @_) if defined $challenge; + my $cleanup = erase_scoped \@basic_keys, $response; + + return digest_data('SHA256', + @basic_keys, + defined $response ? $response : (), + ); +} + +sub hide { + my $self = shift; + $_->hide for @{$self->keys}; + return $self; +} + +sub show { + my $self = shift; + $_->show for @{$self->keys}; + return $self; +} + +sub challenge { + my $self = shift; + my @args = @_; + + my @chalresp_keys = grep { $_->can('challenge') } @{$self->keys} or return ''; + + my @responses = map { $_->challenge(@args) } @chalresp_keys; + my $cleanup = erase_scoped \@responses; + + return digest_data('SHA256', @responses); +} + +=attr keys + + \@keys = $key->keys; + +Get one or more component L<File::KDBX::Key>. + +=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 new file mode 100644 index 0000000..be9abd2 --- /dev/null +++ b/lib/File/KDBX/Key/File.pm @@ -0,0 +1,177 @@ +package File::KDBX::Key::File; +# ABSTRACT: A file key + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Crypt::Misc 0.029 qw(decode_b64); +use File::KDBX::Constants qw(:key_file); +use File::KDBX::Error; +use File::KDBX::Util qw(:erase trim); +use Ref::Util qw(is_ref is_scalarref); +use Scalar::Util qw(openhandle); +use XML::LibXML::Reader; +use namespace::clean; + +use parent 'File::KDBX::Key'; + +our $VERSION = '999.999'; # VERSION + +sub init { + my $self = shift; + my $primitive = shift // throw 'Missing key primitive'; + + my $data; + my $cleanup; + + if (openhandle($primitive)) { + seek $primitive, 0, 0; # not using ->seek method so it works on perl 5.10 + my $buf = do { local $/; <$primitive> }; + $data = \$buf; + $cleanup = erase_scoped $data; + } + elsif (is_scalarref($primitive)) { + $data = $primitive; + } + elsif (defined $primitive && !is_ref($primitive)) { + open(my $fh, '<:raw', $primitive) + or throw "Failed to open key file ($primitive)", filepath => $primitive; + my $buf = do { local $/; <$fh> }; + $data = \$buf; + $cleanup = erase_scoped $data; + $self->{filepath} = $primitive; + } + else { + throw 'Unexpected primitive type', type => ref $primitive; + } + + my $raw_key; + if (substr($$data, 0, 120) =~ /<KeyFile>/ + and my ($type, $version) = $self->_load_xml($data, \$raw_key)) { + $self->{type} = $type; + $self->{version} = $version; + $self->_set_raw_key($raw_key); + } + elsif (length($$data) == 32) { + $self->{type} = KEY_FILE_TYPE_BINARY; + $self->_set_raw_key($$data); + } + elsif ($$data =~ /^[A-Fa-f0-9]{64}$/) { + $self->{type} = KEY_FILE_TYPE_HEX; + $self->_set_raw_key(pack('H64', $$data)); + } + else { + $self->{type} = KEY_FILE_TYPE_HASHED; + $self->_set_raw_key(digest_data('SHA256', $$data)); + } + + return $self->hide; +} + +=method reload + + $key->reload; + +Re-read the key file, if possible, and update the raw key if the key changed. + +=cut + +sub reload { + my $self = shift; + $self->init($self->{filepath}) if defined $self->{filepath}; + return $self; +} + +=attr type + + $type = $key->type; + +Get the type of key file. Can be one of: + +=for :list +* C<KEY_FILE_TYPE_BINARY> +* C<KEY_FILE_TYPE_HEX> +* C<KEY_FILE_TYPE_XML> +* C<KEY_FILE_TYPE_HASHED> + +=cut + +sub type { $_[0]->{type} } + +=attr version + + $version = $key->version; + +Get the file version. Only applies to XML key files. + +=cut + +sub version { $_[0]->{version} } + +=attr filepath + + $filepath = $key->filepath; + +Get the filepath to the key file, if known. + +=cut + +sub filepath { $_[0]->{filepath} } + +############################################################################## + +sub _load_xml { + my $self = shift; + my $buf = shift; + my $out = shift; + + my ($version, $hash, $data); + + my $reader = XML::LibXML::Reader->new(string => $$buf); + my $pattern = XML::LibXML::Pattern->new('/KeyFile/Meta/Version|/KeyFile/Key/Data'); + + while ($reader->nextPatternMatch($pattern) == 1) { + next if $reader->nodeType != XML_READER_TYPE_ELEMENT; + my $name = $reader->localName; + if ($name eq 'Version') { + $reader->read if !$reader->isEmptyElement; + $reader->nodeType == XML_READER_TYPE_TEXT + or alert 'Expected text node with version', line => $reader->lineNumber; + my $val = trim($reader->value); + defined $version + and alert 'Overwriting version', previous => $version, new => $val, line => $reader->lineNumber; + $version = $val; + } + elsif ($name eq 'Data') { + $hash = trim($reader->getAttribute('Hash')) if $reader->hasAttributes; + $reader->read if !$reader->isEmptyElement; + $reader->nodeType == XML_READER_TYPE_TEXT + or alert 'Expected text node with data', line => $reader->lineNumber; + $data = $reader->value; + $data =~ s/\s+//g if defined $data; + } + } + + return if !defined $version || !defined $data; + + if ($version =~ /^1\.0/ && $data =~ /^[A-Za-z0-9+\/=]+$/) { + $$out = eval { decode_b64($data) }; + if (my $err = $@) { + throw 'Failed to decode key in key file', version => $version, data => $data, error => $err; + } + return (KEY_FILE_TYPE_XML, $version); + } + elsif ($version =~ /^2\.0/ && $data =~ /^[A-Fa-f0-9]+$/ && defined $hash && $hash =~ /^[A-Fa-f0-9]+$/) { + $$out = pack('H*', $data); + $hash = pack('H*', $hash); + my $got_hash = digest_data('SHA256', $$out); + $hash eq substr($got_hash, 0, 4) + or throw 'Checksum mismatch', got => $got_hash, expected => $hash; + return (KEY_FILE_TYPE_XML, $version); + } + + throw 'Unexpected data in key file', version => $version, data => $data; +} + +1; diff --git a/lib/File/KDBX/Key/Password.pm b/lib/File/KDBX/Key/Password.pm new file mode 100644 index 0000000..84f8e38 --- /dev/null +++ b/lib/File/KDBX/Key/Password.pm @@ -0,0 +1,26 @@ +package File::KDBX::Key::Password; +# ABSTRACT: A password key + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Encode qw(encode); +use File::KDBX::Error; +use File::KDBX::Util qw(erase); +use namespace::clean; + +use parent 'File::KDBX::Key'; + +our $VERSION = '999.999'; # VERSION + +sub init { + my $self = shift; + my $primitive = shift // throw 'Missing key primitive'; + + $self->_set_raw_key(digest_data('SHA256', encode('UTF-8', $primitive))); + + return $self->hide; +} + +1; diff --git a/lib/File/KDBX/Key/YubiKey.pm b/lib/File/KDBX/Key/YubiKey.pm new file mode 100644 index 0000000..7a7e238 --- /dev/null +++ b/lib/File/KDBX/Key/YubiKey.pm @@ -0,0 +1,445 @@ +package File::KDBX::Key::YubiKey; +# ABSTRACT: A Yubico challenge-response key + +use warnings; +use strict; + +use File::KDBX::Constants qw(:yubikey); +use File::KDBX::Error; +use File::KDBX::Util qw(pad_pkcs7); +use IPC::Open3; +use Scope::Guard; +use Symbol qw(gensym); +use namespace::clean; + +use parent 'File::KDBX::Key::ChallengeResponse'; + +our $VERSION = '999.999'; # VERSION + +my @CONFIG_VALID = (0, CONFIG1_VALID, CONFIG2_VALID); +my @CONFIG_TOUCH = (0, CONFIG1_TOUCH, CONFIG2_TOUCH); + +sub challenge { + my $self = shift; + my $challenge = shift; + my %args = @_; + + my @cleanup; + + my $device = $args{device} // $self->device; + my $slot = $args{slot} // $self->slot; + my $timeout = $args{timeout} // $self->timeout; + local $self->{device} = $device; + local $self->{slot} = $slot; + local $self->{timeout} = $timeout; + + my $hooks = $challenge ne 'test'; + if ($hooks and my $hook = $self->{pre_challenge}) { + $hook->($self, $challenge); + } + + my @cmd = ($self->ykchalresp, "-n$device", "-$slot", qw{-H -i-}, $timeout == 0 ? '-N' : ()); + my ($pid, $child_in, $child_out, $child_err) = _run_ykpers(@cmd); + push @cleanup, Scope::Guard->new(sub { kill $pid if defined $pid }); + + # Set up an alarm [mostly] safely + my $prev_alarm = 0; + local $SIG{ALRM} = sub { + $prev_alarm -= $timeout; + throw 'Timed out while waiting for challenge response', + command => \@cmd, + challenge => $challenge, + timeout => $timeout, + }; + $prev_alarm = alarm $timeout if 0 < $timeout; + push @cleanup, Scope::Guard->new(sub { alarm($prev_alarm < 1 ? 1 : $prev_alarm) }) if $prev_alarm; + + local $SIG{PIPE} = 'IGNORE'; + binmode($child_in); + print $child_in pad_pkcs7($challenge, 64); + close($child_in); + + binmode($child_out); + binmode($child_err); + my $resp = do { local $/; <$child_out> }; + my $err = do { local $/; <$child_err> }; + chomp($resp, $err); + + waitpid($pid, 0); + undef $pid; + my $exit_status = $? >> 8; + alarm 0; + + my $yk_errno = _yk_errno($err); + $exit_status == 0 or throw 'Failed to receive challenge response: ' . ($err ? $err : ''), + error => $err, + yk_errno => $yk_errno || 0; + + $resp =~ /^[A-Fa-f0-9]+$/ or throw 'Unexpected response from challenge', response => $resp; + $resp = pack('H*', $resp); + + # HMAC-SHA1 response is only 20 bytes + substr($resp, 20) = ''; + + if ($hooks and my $hook = $self->{post_challenge}) { + $hook->($self, $challenge, $resp); + } + + return $resp; +} + +=method scan + + @keys = File::KDBX::Key::YubiKey->scan(%options); + +Find connected, configured YubiKeys that are capable of responding to a challenge. This can take several +second. + +Options: + +=for :list +* C<limit> - Scan for only up to this many YubiKeys (default: 4) + +Other options are passed as-is as attributes to the key constructors of found keys (if any). + +=cut + +sub scan { + my $self = shift; + my %args = @_; + + my $limit = delete $args{limit} // 4; + + my @keys; + for (my $device = 0; $device < $limit; ++$device) { + my %info = $self->_get_yubikey_info($device) or last; + + for (my $slot = 1; $slot <= 2; ++$slot) { + my $config = $CONFIG_VALID[$slot] // next; + next unless $info{touch_level} & $config; + + my $key = $self->new(%args, device => $device, slot => $slot, %info); + if ($info{product_id} <= NEO_OTP_U2F_CCID_PID) { + # NEO and earlier always require touch, so forego testing + $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]); + push @keys, $key; + } + else { + eval { $key->challenge('test', timeout => 0) }; + if (my $err = $@) { + my $yk_errno = ref $err && $err->details->{yk_errno} || 0; + if ($yk_errno == YK_EWOULDBLOCK) { + $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]); + } + elsif ($yk_errno != 0) { + # alert $err; + next; + } + } + push @keys, $key; + } + } + } + + return @keys; +} + +=attr device + + $device = $key->device($device); + +Get or set the device number, which is the index number starting and incrementing from zero assigned +to the YubiKey device. If there is only one detected YubiKey device, it's number is C<0>. + +Defaults to C<0>. + +=attr slot + + $slot = $key->slot($slot); + +Get or set the slot number, which is a number starting and incrementing from one. A YubiKey can have +multiple slots (often just two) which can be independently configured. + +Defaults to C<1>. + +=attr timeout + + $timeout = $key->timeout($timeout); + +Get or set the timeout, in seconds. If the challenge takes longer than this, the challenge will be +cancelled and an error is thrown. + +If the timeout is zero, the challenge is non-blocking; an error is thrown if the challenge would +block. If the timeout is negative, timeout is disabled and the challenge will block forever or until +a response is received. + +Defaults to C<0>. + +=attr pre_challenge + + $callback = $key->pre_challenge($callback); + +Get or set a callback function that will be called immediately before any challenge is issued. This might be +used to prompt the user so they are aware that they are expected to interact with their YubiKey. + + $key->pre_challenge(sub { + my ($key, $challenge) = @_; + + if ($key->requires_interaction) { + say 'Please touch your key device to proceed with decrypting your KDBX file.'; + } + say 'Key: ', $key->name; + if (0 < $key->timeout) { + say 'Key access request expires: ' . localtime(time + $key->timeout); + } + }); + +You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping +a KDBX database, the entire load/dump will be aborted. + +=attr post_challenge + + $callback = $key->post_challenge($callback); + +Get or set a callback function that will be called immediately after a challenge response has been received. + +You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping +a KDBX database, the entire load/dump will be aborted. + +=attr ykchalresp + + $program = $key->ykchalresp; + +Get or set the L<ykchalresp(1)> program name or filepath. Defaults to C<$ENV{YKCHALRESP}> or C<ykchalresp>. + +=attr ykinfo + + $program = $key->ykinfo; + +Get or set the L<ykinfo(1)> program name or filepath. Defaults to C<$ENV{YKINFO}> or C<ykinfo>. + +=cut + +my %ATTRS = ( + device => 0, + slot => 1, + timeout => 10, + pre_challenge => undef, + post_challenge => undef, + ykchalresp => sub { $ENV{YKCHALRESP} || 'ykchalresp' }, + ykinfo => sub { $ENV{YKINFO} || 'ykinfo' }, +); +while (my ($subname, $default) = each %ATTRS) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$subname} = sub { + my $self = shift; + $self->{$subname} = shift if @_; + $self->{$subname} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} + +my %INFO = ( + serial => undef, + version => undef, + touch_level => undef, + vendor_id => undef, + product_id => undef, +); +while (my ($subname, $default) = each %INFO) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$subname} = sub { + my $self = shift; + $self->{$subname} = shift if @_; + defined $self->{$subname} or $self->_set_yubikey_info; + $self->{$subname} // $default; + }; +} + +=method serial + +Get the device serial number, as a number, or C<undef> if there is no such device. + +=method version + +Get the device firmware version (or C<undef>). + +=method touch_level + +Get the "touch level" value for the device associated with this key (or C<undef>). + +=method vendor_id + +=method product_id + +Get the vendor ID or product ID for the device associated with this key (or C<undef>). + +=method name + + $name = $key->name; + +Get a human-readable string identifying the YubiKey (or C<undef>). + +=cut + +sub name { + my $self = shift; + my $name = _product_name($self->vendor_id, $self->product_id // return); + my $serial = $self->serial; + my $version = $self->version || '?'; + my $slot = $self->slot; + my $touch = $self->requires_interaction ? ' - Interaction required' : ''; + return sprintf('%s v%s [%d] (slot #%d)', $name, $version, $serial, $slot); +} + +=method requires_interaction + +Get whether or not the key requires interaction (e.g. a touch) to provide a challenge response (or C<undef>). + +=cut + +sub requires_interaction { + my $self = shift; + my $touch = $self->touch_level // return; + return $touch & $CONFIG_TOUCH[$self->slot]; +} + +############################################################################## + +### Call ykinfo to get some information about a YubiKey +sub _get_yubikey_info { + my $self = shift; + my $device = shift; + + my @cmd = ($self->ykinfo, "-n$device", qw{-a}); + + my $try = 0; + TRY: + my ($pid, $child_in, $child_out, $child_err) = _run_ykpers(@cmd); + + close($child_in); + + local $SIG{PIPE} = 'IGNORE'; + binmode($child_out); + binmode($child_err); + my $out = do { local $/; <$child_out> }; + my $err = do { local $/; <$child_err> }; + chomp $err; + + waitpid($pid, 0); + my $exit_status = $? >> 8; + + if ($exit_status != 0) { + my $yk_errno = _yk_errno($err); + return if $yk_errno == YK_ENOKEY; + if ($yk_errno == YK_EWOULDBLOCK && ++$try <= 3) { + sleep 0.1; + goto TRY; + } + alert 'Failed to get YubiKey device info: ' . ($err ? $err : 'Something happened'), + error => $err, + yk_errno => $yk_errno || 0; + return; + } + + if (!$out) { + alert 'Failed to get YubiKey device info: no output'; + return; + } + + my %info = map { $_ => ($out =~ /^\Q$_\E: (.+)$/m)[0] } + qw(serial version touch_level vendor_id product_id); + $info{vendor_id} = hex($info{vendor_id}) if defined $info{vendor_id}; + $info{product_id} = hex($info{product_id}) if defined $info{product_id}; + + return %info; +} + +### Set the YubiKey information as attributes of a Key object +sub _set_yubikey_info { + my $self = shift; + my %info = $self->_get_yubikey_info($self->device); + @$self{keys %info} = values %info; +} + +sub _run_ykpers { + my ($child_err, $child_in, $child_out) = (gensym); + my $pid = eval { open3($child_in, $child_out, $child_err, @_) }; + if (my $err = $@) { + throw "Failed to run $_[0] - Make sure you have the YubiKey Personalization Tool (CLI) package installed.\n", + error => $err; + } + return ($pid, $child_in, $child_out, $child_err); +} + +sub _yk_errno { + local $_ = shift or return 0; + return YK_EUSBERR if $_ =~ YK_EUSBERR; + return YK_EWRONGSIZ if $_ =~ YK_EWRONGSIZ; + return YK_EWRITEERR if $_ =~ YK_EWRITEERR; + return YK_ETIMEOUT if $_ =~ YK_ETIMEOUT; + return YK_ENOKEY if $_ =~ YK_ENOKEY; + return YK_EFIRMWARE if $_ =~ YK_EFIRMWARE; + return YK_ENOMEM if $_ =~ YK_ENOMEM; + return YK_ENOSTATUS if $_ =~ YK_ENOSTATUS; + return YK_ENOTYETIMPL if $_ =~ YK_ENOTYETIMPL; + return YK_ECHECKSUM if $_ =~ YK_ECHECKSUM; + return YK_EWOULDBLOCK if $_ =~ YK_EWOULDBLOCK; + return YK_EINVALIDCMD if $_ =~ YK_EINVALIDCMD; + return YK_EMORETHANONE if $_ =~ YK_EMORETHANONE; + return YK_ENODATA if $_ =~ YK_ENODATA; + return -1; +} + +my %PIDS; +for my $pid ( + YUBIKEY_PID, NEO_OTP_PID, NEO_OTP_CCID_PID, NEO_CCID_PID, NEO_U2F_PID, NEO_OTP_U2F_PID, NEO_U2F_CCID_PID, + NEO_OTP_U2F_CCID_PID, YK4_OTP_PID, YK4_U2F_PID, YK4_OTP_U2F_PID, YK4_CCID_PID, YK4_OTP_CCID_PID, + YK4_U2F_CCID_PID, YK4_OTP_U2F_CCID_PID, PLUS_U2F_OTP_PID, ONLYKEY_PID, +) { + $PIDS{$pid} = $PIDS{0+$pid} = $pid; +} +sub _product_name { $PIDS{$_[1]} // 'Unknown' } + +1; +__END__ + +=head1 SYNOPSIS + + use File::KDBX::Key::YubiKey; + use File::KDBX; + + my $yubikey = File::KDBX::Key::YubiKey->new(%attributes); + + my $kdbx = File::KDBX->load_file('database.kdbx', $yubikey); + # OR + my $kdbx = File::KDBX->load_file('database.kdbx', ['password', $yubikey]); + + # Scan for USB YubiKeys: + my ($first_key, @other_keys) = File::KDBX::Key::YubiKey->scan; + + my $response = $first_key->challenge('hello'); + +=head1 DESCRIPTION + +A L<File::KDBX::Key::YubiKey> is a type of challenge-response key. This module follows the KeePassXC-style +challenge-response implementation, so this might not work at all with incompatible challenge-response +implementations (e.g. KeeChallenge). + +To use this type of key to secure a L<File::KDBX> database, you also need to install the +L<YubiKey Personalization Tool (CLI)|https://developers.yubico.com/yubikey-personalization/> and configure at +least one of the slots on your YubiKey for HMAC-SHA1 challenge response mode. You can use the YubiKey +Personalization Tool GUI to do this. + +See L<https://keepassxc.org/docs/#faq-yubikey-howto> for more information. + +=head1 ENVIRONMENT + +=for :list +* C<YKCHALRESP> - Path to the L<ykchalresp(1)> program +* C<YKINFO> - Path to the L<ykinfo(1)> program + +C<YubiKey> searches for these programs in the same way perl typically searches for executables (using the +C<PATH> environment variable on many platforms). If the programs aren't installed normally, or if you want to +override the default programs, these environment variables can be used. + +=cut diff --git a/lib/File/KDBX/Loader.pm b/lib/File/KDBX/Loader.pm new file mode 100644 index 0000000..844f038 --- /dev/null +++ b/lib/File/KDBX/Loader.pm @@ -0,0 +1,338 @@ +package File::KDBX::Loader; +# ABSTRACT: Load KDBX files + +use warnings; +use strict; + +use File::KDBX::Constants qw(:magic :header :version); +use File::KDBX::Error; +use File::KDBX::Util qw(:io); +use File::KDBX; +use IO::Handle; +use Module::Load (); +use Ref::Util qw(is_ref is_scalarref); +use Scalar::Util qw(looks_like_number openhandle); +use namespace::clean; + +our $VERSION = '999.999'; # VERSION + +=method new + + $loader = File::KDBX::Loader->new(%attributes); + +Construct a new L<File::KDBX::Loader>. + +=cut + +sub new { + my $class = shift; + my $self = bless {}, $class; + $self->init(@_); +} + +=method init + + $loader = $loader->init(%attributes); + +Initialize a L<File::KDBX::Loader> with a new set of attributes. + +This is called by L</new>. + +=cut + +sub init { + my $self = shift; + my %args = @_; + + @$self{keys %args} = values %args; + + return $self; +} + +sub _rebless { + my $self = shift; + my $format = shift // $self->format; + + my $sig2 = $self->kdbx->sig2; + my $version = $self->kdbx->version; + + my $subclass; + + if (defined $format) { + $subclass = $format; + } + elsif (defined $sig2 && $sig2 == KDBX_SIG2_1) { + $subclass = 'KDB'; + } + elsif (looks_like_number($version)) { + my $major = $version & KDBX_VERSION_MAJOR_MASK; + my %subclasses = ( + KDBX_VERSION_2_0() => 'V3', + KDBX_VERSION_3_0() => 'V3', + KDBX_VERSION_4_0() => 'V4', + ); + $subclass = $subclasses{$major} + or throw sprintf('Unsupported KDBX file version: %x', $version), version => $version; + } + else { + throw sprintf('Unknown file version: %s', $version), version => $version; + } + + Module::Load::load "File::KDBX::Loader::$subclass"; + bless $self, "File::KDBX::Loader::$subclass"; +} + +=method reset + + $loader = $loader->reset; + +Set a L<File::KDBX::Loader> to a blank state, ready to load another KDBX file. + +=cut + +sub reset { + my $self = shift; + %$self = (); + return $self; +} + +=method load + + $kdbx = File::KDBX::Loader->load(\$string, $key); + $kdbx = File::KDBX::Loader->load(*IO, $key); + $kdbx = File::KDBX::Loader->load($filepath, $key); + $kdbx = $loader->load(...); # also instance method + +Load a KDBX file. + +The C<$key> is either a L<File::KDBX::Key> or a primitive that can be converted to a Key object. + +=cut + +sub load { + my $self = shift; + my $src = shift; + return $self->load_handle($src, @_) if openhandle($src) || $src eq '-'; + return $self->load_string($src, @_) if is_scalarref($src); + return $self->load_file($src, @_) if !is_ref($src) && defined $src; + throw 'Programmer error: Must pass a stringref, filepath or IO handle to read'; +} + +=method load_string + + $kdbx = File::KDBX::Loader->load_string($string, $key); + $kdbx = File::KDBX::Loader->load_string(\$string, $key); + $kdbx = $loader->load_string(...); # also instance method + +Load a KDBX file from a string / memory buffer. + +=cut + +sub load_string { + my $self = shift; + my $str = shift or throw 'Expected string to load'; + my %args = @_ % 2 == 0 ? @_ : (key => shift, @_); + + my $key = delete $args{key}; + $args{kdbx} //= $self->kdbx; + + my $ref = is_scalarref($str) ? $str : \$str; + + open(my $fh, '<', $ref) or throw "Failed to open string buffer: $!"; + + $self = $self->new if !ref $self; + $self->init(%args, fh => $fh)->_read($fh, $key); + return $args{kdbx}; +} + +=method load_file + + $kdbx = File::KDBX::Loader->load_file($filepath, $key); + $kdbx = $loader->load_file(...); # also instance method + +Read a KDBX file from a filesystem. + +=cut + +sub load_file { + my $self = shift; + my $filepath = shift; + my %args = @_ % 2 == 0 ? @_ : (key => shift, @_); + + my $key = delete $args{key}; + $args{kdbx} //= $self->kdbx; + + open(my $fh, '<:raw', $filepath) or throw 'Open file failed', filepath => $filepath; + + $self = $self->new if !ref $self; + $self->init(%args, fh => $fh, filepath => $filepath)->_read($fh, $key); + return $args{kdbx}; +} + +=method load_handle + + $kdbx = File::KDBX::Loader->load_handle($fh, $key); + $kdbx = File::KDBX::Loader->load_handle(*IO, $key); + $kdbx->load_handle(...); # also instance method + +Read a KDBX file from an input stream / file handle. + +=cut + +sub load_handle { + my $self = shift; + my $fh = shift; + my %args = @_ % 2 == 0 ? @_ : (key => shift, @_); + + $fh = *STDIN if $fh eq '-'; + + my $key = delete $args{key}; + $args{kdbx} //= $self->kdbx; + + $self = $self->new if !ref $self; + $self->init(%args, fh => $fh)->_read($fh, $key); + return $args{kdbx}; +} + +=attr kdbx + + $kdbx = $loader->kdbx; + $loader->kdbx($kdbx); + +Get or set the L<File::KDBX> instance for storing the loaded data into. + +=cut + +sub kdbx { + my $self = shift; + return File::KDBX->new if !ref $self; + $self->{kdbx} = shift if @_; + $self->{kdbx} //= File::KDBX->new; +} + +=attr format + +TODO + +=cut + +sub format { $_[0]->{format} } +sub inner_format { $_[0]->{inner_format} // 'XML' } + +=attr min_version + + $min_version = File::KDBX::Loader->min_version; + +Get the minimum KDBX file version supported, which is 3.0 or C<0x00030000> as +it is encoded. + +To read older KDBX files unsupported by this module, try L<File::KeePass>. + +=cut + +sub min_version { KDBX_VERSION_OLDEST } + +=method read_magic_numbers + + $magic = File::KDBX::Loader->read_magic_numbers($fh); + ($sig1, $sig2, $version, $magic) = File::KDBX::Loader->read_magic_numbers($fh); + + $magic = $loader->read_magic_numbers($fh); + ($sig1, $sig2, $version, $magic) = $loader->read_magic_numbers($fh); + +Read exactly 12 bytes from an IO handle and parse them into the three magic numbers that begin +a KDBX file. This is a quick way to determine if a file is actually a KDBX file. + +C<$sig1> should always be C<KDBX_SIG1> if reading an actual KDB or KDBX file. + +C<$sig2> should be C<KDBX_SIG2_1> for KeePass 1 files and C<KDBX_SIG2_2> for KeePass 2 files. + +C<$version> is the file version (e.g. C<0x00040001>). + +C<$magic> is the raw 12 bytes read from the IO handle. + +If called on an instance, the C<sig1>, C<sig2> and C<version> attributes will be set in the L</kdbx> +and the instance will be blessed into the correct loader subclass. + +=cut + +sub read_magic_numbers { + my $self = shift; + my $fh = shift; + my $kdbx = shift // $self->kdbx; + + read_all $fh, my $magic, 12 or throw 'Failed to read file signature'; + + my ($sig1, $sig2, $version) = unpack('L<3', $magic); + + if ($kdbx) { + $kdbx->sig1($sig1); + $kdbx->sig2($sig2); + $kdbx->version($version); + $self->_rebless if ref $self; + } + + return wantarray ? ($sig1, $sig2, $version, $magic) : $magic; +} + +sub _fh { $_[0]->{fh} or throw 'IO handle not set' } + +sub _read { + my $self = shift; + my $fh = shift; + my $key = shift; + + my $kdbx = $self->kdbx; + $key //= $kdbx->key ? $kdbx->key->reload : undef; + $kdbx->reset; + + read_all $fh, my $buf, 1 or throw 'Failed to read the first byte', type => 'parser'; + my $first = ord($buf); + $fh->ungetc($first); + if ($first != KDBX_SIG1_FIRST_BYTE) { + # not a KDBX file... try skipping the outer layer + return $self->_read_inner_body($fh); + } + + my $magic = $self->read_magic_numbers($fh, $kdbx); + $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', type => 'parser', sig1 => $kdbx->sig1; + + if (ref($self) =~ /::(?:KDB|V[34])$/) { + defined $key or throw 'Must provide a master key', type => 'key.missing'; + } + + my $headers = $self->_read_headers($fh); + + $self->_read_body($fh, $key, "$magic$headers"); +} + +sub _read_headers { + my $self = shift; + my $fh = shift; + + my $headers = $self->kdbx->headers; + my $all_raw = ''; + + while (my ($type, $val, $raw) = $self->_read_header($fh)) { + $all_raw .= $raw; + last if $type == HEADER_END; + $headers->{$type} = $val; + } + + return $all_raw; +} + +sub _read_body { die "Not implemented" } + +sub _read_inner_body { + my $self = shift; + + my $current_pkg = ref $self; + require Scope::Guard; + my $guard = Scope::Guard->new(sub { bless $self, $current_pkg }); + + $self->_rebless($self->inner_format); + $self->_read_inner_body(@_); +} + +1; diff --git a/lib/File/KDBX/Loader/KDB.pm b/lib/File/KDBX/Loader/KDB.pm new file mode 100644 index 0000000..1f0cb3d --- /dev/null +++ b/lib/File/KDBX/Loader/KDB.pm @@ -0,0 +1,402 @@ +package File::KDBX::Loader::KDB; +# ABSTRACT: Read KDB files + +use warnings; +use strict; + +use Encode qw(encode); +use File::KDBX::Constants qw(:header :cipher :random_stream :icon); +use File::KDBX::Error; +use File::KDBX::Util qw(:empty :io :uuid load_optional); +use File::KDBX; +use Ref::Util qw(is_arrayref is_hashref); +use Scalar::Util qw(looks_like_number); +use Time::Piece; +use boolean; +use namespace::clean; + +use parent 'File::KDBX::Loader'; + +our $VERSION = '999.999'; # VERSION + +my $DEFAULT_EXPIRATION = Time::Piece->new(32503677839); # 2999-12-31 23:59:59 + +sub _read_headers { '' } + +sub _read_body { + my $self = shift; + my $fh = shift; + my $key = shift; + my $buf = shift; + + load_optional('File::KeePass'); + + $buf .= do { local $/; <$fh> }; + + $key = $self->kdbx->composite_key($key, keep_primitive => 1); + + my $k = eval { File::KeePass->new->parse_db(\$buf, _convert_kdbx_to_keepass_master_key($key)) }; + if (my $err = $@) { + throw 'Failed to parse KDB file', error => $err; + } + + $k->unlock; + $self->kdbx->key($key); + + return convert_keepass_to_kdbx($k, $self->kdbx); +} + +# This is also used by File::KDBX::Dumper::KDB. +sub _convert_kdbx_to_keepass_master_key { + my $key = shift; + + my @keys = @{$key->keys}; + if (@keys == 1 && !$keys[0]->can('filepath')) { + return [encode('CP-1252', $keys[0]->{primitive})]; # just a password + } + elsif (@keys == 1) { + return [undef, \$keys[0]->raw_key]; # just a keyfile + } + elsif (@keys == 2 && !$keys[0]->can('filepath') && $keys[1]->can('filepath')) { + return [encode('CP-1252', $keys[0]->{primitive}), \$keys[1]->raw_key]; + } + throw 'Cannot use this key to load a KDB file', key => $key; +} + +=func convert_keepass_to_kdbx + + $kdbx = convert_keepass_to_kdbx($keepass); + $kdbx = convert_keepass_to_kdbx($keepass, $kdbx); + +Convert a L<File::KeePass> to a L<File::KDBX>. + +=cut + +sub convert_keepass_to_kdbx { + my $k = shift; + my $kdbx = shift // File::KDBX->new; + + $kdbx->{headers} //= {}; + _convert_keepass_to_kdbx_headers($k->{header}, $kdbx); + + my @groups = @{$k->{groups} || []}; + if (@groups == 1) { + $kdbx->{root} = _convert_keepass_to_kdbx_group($k->{groups}[0]); + } + elsif (1 < @groups) { + my $root = $kdbx->{root} = {%{File::KDBX->_implicit_root}}; + for my $group (@groups) { + push @{$root->{groups} //= []}, _convert_keepass_to_kdbx_group($group); + } + } + + for my $entry ($kdbx->find_entries({ + title => 'Meta-Info', + username => 'SYSTEM', + url => '$', + icon_id => 0, + -nonempty => 'notes', + })) { + _read_meta_stream($kdbx, $entry); + $entry->remove; + } + + return $kdbx; +} + +sub _read_meta_stream { + my $kdbx = shift; + my $entry = shift; + + my $type = $entry->notes; + my $data = $entry->binary_value('bin-stream'); + open(my $fh, '<', \$data) or throw "Failed to open memory buffer for reading: $!"; + + if ($type eq 'KPX_GROUP_TREE_STATE') { + read_all $fh, my $buf, 4 or goto PARSE_ERROR; + my ($num) = unpack('L<', $buf); + $num * 5 + 4 == length($data) or goto PARSE_ERROR; + for (my $i = 0; $i < $num; ++$i) { + read_all $fh, $buf, 5 or goto PARSE_ERROR; + my ($group_id, $expanded) = unpack('L< C', $buf); + my $uuid = _decode_uuid($group_id) // next; + my ($group) = $kdbx->find_groups({uuid => $uuid}); + $group->is_expanded($expanded) if $group; + } + } + elsif ($type eq 'KPX_CUSTOM_ICONS_4') { + read_all $fh, my $buf, 12 or goto PARSE_ERROR; + my ($num_icons, $num_entries, $num_groups) = unpack('L<3', $buf); + my @icons; + for (my $i = 0; $i < $num_icons; ++$i) { + read_all $fh, $buf, 4 or goto PARSE_ERROR; + my ($icon_size) = unpack('L<', $buf); + read_all $fh, $buf, $icon_size or goto PARSE_ERROR; + my $uuid = $kdbx->add_custom_icon($buf); + push @icons, $uuid; + } + for (my $i = 0; $i < $num_entries; ++$i) { + read_all $fh, $buf, 20 or goto PARSE_ERROR; + my ($uuid, $icon_index) = unpack('a16 L<', $buf); + next if !$icons[$icon_index]; + my ($entry) = $kdbx->find_entries({uuid => $uuid}); + $entry->custom_icon_uuid($icons[$icon_index]) if $entry; + } + for (my $i = 0; $i < $num_groups; ++$i) { + read_all $fh, $buf, 8 or goto PARSE_ERROR; + my ($group_id, $icon_index) = unpack('L<2', $buf); + next if !$icons[$icon_index]; + my $uuid = _decode_uuid($group_id) // next; + my ($group) = $kdbx->find_groups({uuid => $uuid}); + $group->custom_icon_uuid($icons[$icon_index]) if $group; + } + } + else { + alert "Ignoring unknown meta stream: $type\n", type => $type; + return; + } + + return; + + PARSE_ERROR: + alert "Ignoring unparsable meta stream: $type\n", type => $type; +} + +sub _convert_keepass_to_kdbx_headers { + my $from = shift; + my $kdbx = shift; + + my $headers = $kdbx->{headers} //= {}; + my $meta = $kdbx->{meta} //= {}; + + $kdbx->{sig1} = $from->{sig1}; + $kdbx->{sig2} = $from->{sig2}; + $kdbx->{version} = $from->{vers}; + + my %enc_type = ( + rijndael => CIPHER_UUID_AES256, + aes => CIPHER_UUID_AES256, + twofish => CIPHER_UUID_TWOFISH, + chacha20 => CIPHER_UUID_CHACHA20, + salsa20 => CIPHER_UUID_SALSA20, + serpent => CIPHER_UUID_SERPENT, + ); + my $cipher_uuid = $enc_type{$from->{cipher} || ''} // $enc_type{$from->{enc_type} || ''}; + + my %protected_stream = ( + rc4 => STREAM_ID_RC4_VARIANT, + salsa20 => STREAM_ID_SALSA20, + chacha20 => STREAM_ID_CHACHA20, + ); + my $protected_stream_id = $protected_stream{$from->{protected_stream} || ''} || STREAM_ID_SALSA20; + + $headers->{+HEADER_COMMENT} = $from->{comment}; + $headers->{+HEADER_CIPHER_ID} = $cipher_uuid if $cipher_uuid; + $headers->{+HEADER_MASTER_SEED} = $from->{seed_rand}; + $headers->{+HEADER_COMPRESSION_FLAGS} = $from->{compression} // 0; + $headers->{+HEADER_TRANSFORM_SEED} = $from->{seed_key}; + $headers->{+HEADER_TRANSFORM_ROUNDS} = $from->{rounds}; + $headers->{+HEADER_ENCRYPTION_IV} = $from->{enc_iv}; + $headers->{+HEADER_INNER_RANDOM_STREAM_ID} = $protected_stream_id; + $headers->{+HEADER_INNER_RANDOM_STREAM_KEY} = $from->{protected_stream_key}; + $headers->{+HEADER_STREAM_START_BYTES} = $from->{start_bytes} // ''; + + # TODO for KeePass 1 files these are all not available. Leave undefined or set default values? + $meta->{memory_protection}{protect_notes} = boolean($from->{protect_notes}); + $meta->{memory_protection}{protect_password} = boolean($from->{protect_password}); + $meta->{memory_protection}{protect_username} = boolean($from->{protect_username}); + $meta->{memory_protection}{protect_url} = boolean($from->{protect_url}); + $meta->{memory_protection}{protect_title} = boolean($from->{protect_title}); + $meta->{generator} = $from->{generator} // ''; + $meta->{header_hash} = $from->{header_hash}; + $meta->{database_name} = $from->{database_name} // ''; + $meta->{database_name_changed} = _decode_datetime($from->{database_name_changed}); + $meta->{database_description} = $from->{database_description} // ''; + $meta->{database_description_changed} = _decode_datetime($from->{database_description_changed}); + $meta->{default_username} = $from->{default_user_name} // ''; + $meta->{default_username_changed} = _decode_datetime($from->{default_user_name_changed}); + $meta->{maintenance_history_days} = $from->{maintenance_history_days}; + $meta->{color} = $from->{color}; + $meta->{master_key_changed} = _decode_datetime($from->{master_key_changed}); + $meta->{master_key_change_rec} = $from->{master_key_change_rec}; + $meta->{master_key_change_force} = $from->{master_key_change_force}; + $meta->{recycle_bin_enabled} = boolean($from->{recycle_bin_enabled}); + $meta->{recycle_bin_uuid} = $from->{recycle_bin_uuid}; + $meta->{recycle_bin_changed} = _decode_datetime($from->{recycle_bin_changed}); + $meta->{entry_templates_group} = $from->{entry_templates_group}; + $meta->{entry_templates_group_changed} = _decode_datetime($from->{entry_templates_group_changed}); + $meta->{last_selected_group} = $from->{last_selected_group}; + $meta->{last_top_visible_group} = $from->{last_top_visible_group}; + $meta->{history_max_items} = $from->{history_max_items}; + $meta->{history_max_size} = $from->{history_max_size}; + $meta->{settings_changed} = _decode_datetime($from->{settings_changed}); + + while (my ($key, $value) = each %{$from->{custom_icons} || {}}) { + $meta->{custom_icons}{$key} = {value => $value}; + } + while (my ($key, $value) = each %{$from->{custom_data} || {}}) { + $meta->{custom_data}{$key} = {value => $value}; + } + + return $kdbx; +} + +sub _convert_keepass_to_kdbx_group { + my $from = shift; + my $to = shift // {}; + my %args = @_; + + $to->{times}{last_access_time} = _decode_datetime($from->{accessed}); + $to->{times}{usage_count} = $from->{usage_count} || 0; + $to->{times}{expiry_time} = _decode_datetime($from->{expires}, $DEFAULT_EXPIRATION); + $to->{times}{expires} = defined $from->{expires_enabled} + ? boolean($from->{expires_enabled}) + : boolean($to->{times}{expiry_time} <= gmtime); + $to->{times}{creation_time} = _decode_datetime($from->{created}); + $to->{times}{last_modification_time} = _decode_datetime($from->{modified}); + $to->{times}{location_changed} = _decode_datetime($from->{location_changed}); + $to->{notes} = $from->{notes} // ''; + $to->{uuid} = _decode_uuid($from->{id}); + $to->{is_expanded} = boolean($from->{expanded}); + $to->{icon_id} = $from->{icon} // ICON_FOLDER; + $to->{name} = $from->{title} // ''; + $to->{default_auto_type_sequence} = $from->{auto_type_default} // ''; + $to->{enable_auto_type} = _decode_tristate($from->{auto_type_enabled}); + $to->{enable_searching} = _decode_tristate($from->{enable_searching}); + $to->{groups} = []; + $to->{entries} = []; + + if (!$args{shallow}) { + for my $group (@{$from->{groups} || []}) { + push @{$to->{groups}}, _convert_keepass_to_kdbx_group($group); + } + for my $entry (@{$from->{entries} || []}) { + push @{$to->{entries}}, _convert_keepass_to_kdbx_entry($entry); + } + } + + return $to; +} + +sub _convert_keepass_to_kdbx_entry { + my $from = shift; + my $to = shift // {}; + my %args = @_; + + $to->{times}{last_access_time} = _decode_datetime($from->{accessed}); + $to->{times}{usage_count} = $from->{usage_count} || 0; + $to->{times}{expiry_time} = _decode_datetime($from->{expires}, $DEFAULT_EXPIRATION); + $to->{times}{expires} = defined $from->{expires_enabled} + ? boolean($from->{expires_enabled}) + : boolean($to->{times}{expiry_time} <= gmtime); + $to->{times}{creation_time} = _decode_datetime($from->{created}); + $to->{times}{last_modification_time} = _decode_datetime($from->{modified}); + $to->{times}{location_changed} = _decode_datetime($from->{location_changed}); + + $to->{auto_type}{data_transfer_obfuscation} = $from->{auto_type_munge} || false; + $to->{auto_type}{enabled} = boolean($from->{auto_type_enabled} // 1); + + my $comment = $from->{comment}; + my @auto_type = is_arrayref($from->{auto_type}) ? @{$from->{auto_type}} : (); + + if (!@auto_type && nonempty $from->{auto_type} && nonempty $from->{auto_type_window} + && !is_hashref($from->{auto_type})) { + @auto_type = ({window => $from->{auto_type_window}, keys => $from->{auto_type}}); + } + if (nonempty $comment) { + my @AT; + my %atw = my @atw = $comment =~ m{ ^Auto-Type-Window((?:-?\d+)?): [\t ]* (.*?) [\t ]*$ }mxg; + my %atk = my @atk = $comment =~ m{ ^Auto-Type((?:-?\d+)?): [\t ]* (.*?) [\t ]*$ }mxg; + $comment =~ s{ ^Auto-Type(?:-Window)?(?:-?\d+)?: .* \n? }{}mxg; + while (@atw) { + my ($n, $w) = (shift(@atw), shift(@atw)); + push @AT, {window => $w, keys => exists($atk{$n}) ? $atk{$n} : $atk{''}}; + } + while (@atk) { + my ($n, $k) = (shift(@atk), shift(@atk)); + push @AT, {keys => $k, window => exists($atw{$n}) ? $atw{$n} : $atw{''}}; + } + for (@AT) { + $_->{'window'} //= ''; + $_->{'keys'} //= ''; + } + my %uniq; + @AT = grep {!$uniq{"$_->{'window'}\e$_->{'keys'}"}++} @AT; + push @auto_type, @AT; + } + $to->{auto_type}{associations} = [ + map { +{window => $_->{window}, keystroke_sequence => $_->{keys}} } @auto_type, + ]; + + $to->{strings}{Notes}{value} = $comment; + $to->{strings}{UserName}{value} = $from->{username}; + $to->{strings}{Password}{value} = $from->{password}; + $to->{strings}{URL}{value} = $from->{url}; + $to->{strings}{Title}{value} = $from->{title}; + $to->{strings}{Notes}{protect} = true if defined $from->{protected}{comment}; + $to->{strings}{UserName}{protect} = true if defined $from->{protected}{username}; + $to->{strings}{Password}{protect} = true if $from->{protected}{password} // 1; + $to->{strings}{URL}{protect} = true if defined $from->{protected}{url}; + $to->{strings}{Title}{protect} = true if defined $from->{protected}{title}; + + # other strings + while (my ($key, $value) = each %{$from->{strings} || {}}) { + $to->{strings}{$key} = { + value => $value, + $from->{protected}{$key} ? (protect => true) : (), + }; + } + + $to->{override_url} = $from->{override_url}; + $to->{tags} = $from->{tags} // ''; + $to->{icon_id} = $from->{icon} // ICON_PASSWORD; + $to->{uuid} = _decode_uuid($from->{id}); + $to->{foreground_color} = $from->{foreground_color} // ''; + $to->{background_color} = $from->{background_color} // ''; + $to->{custom_icon_uuid} = $from->{custom_icon_uuid}; + $to->{history} = []; + + local $from->{binary} = {$from->{binary_name} => $from->{binary}} + if nonempty $from->{binary} && nonempty $from->{binary_name} && !is_hashref($from->{binary}); + while (my ($key, $value) = each %{$from->{binary} || {}}) { + $to->{binaries}{$key} = {value => $value}; + } + + if (!$args{shallow}) { + for my $entry (@{$from->{history} || []}) { + my $new_entry = {}; + push @{$to->{entries}}, _convert_keepass_to_kdbx_entry($entry, $new_entry); + } + } + + return $to; +} + +sub _decode_datetime { + local $_ = shift // return shift // gmtime; + return Time::Piece->strptime($_, '%Y-%m-%d %H:%M:%S'); +} + +sub _decode_uuid { + local $_ = shift // return; + # Group IDs in KDB files are 32-bit integers + return sprintf('%016x', $_) if length($_) != 16 && looks_like_number($_); + return $_; +} + +sub _decode_tristate { + local $_ = shift // return; + return boolean($_); +} + +1; +__END__ + +=head1 DESCRIPTION + +Read older KDB (KeePass 1) files. This feature requires an additional module to be installed: + +=for :list +* L<File::KeePass> + +=cut diff --git a/lib/File/KDBX/Loader/Raw.pm b/lib/File/KDBX/Loader/Raw.pm new file mode 100644 index 0000000..58e920d --- /dev/null +++ b/lib/File/KDBX/Loader/Raw.pm @@ -0,0 +1,50 @@ +package File::KDBX::Loader::Raw; +# ABSTRACT: A no-op loader that doesn't do any parsing + +use warnings; +use strict; + +use parent 'File::KDBX::Loader'; + +our $VERSION = '999.999'; # VERSION + +sub _read { + my $self = shift; + my $fh = shift; + + $self->_read_body($fh); +} + +sub _read_body { + my $self = shift; + my $fh = shift; + + $self->_read_inner_body($fh); +} + +sub _read_inner_body { + my $self = shift; + my $fh = shift; + + my $content = do { local $/; <$fh> }; + $self->kdbx->raw($content); +} + +1; +__END__ + +=head1 SYNOPSIS + + use File::KDBX::Loader; + + my $kdbx = File::KDBX::Loader->load_file('file.kdbx', $key, inner_format => 'Raw'); + print $kdbx->raw; + +=head1 DESCRIPTION + +A typical KDBX file is made up of an outer section (with headers) and an inner section (with the body). The +inner section is usually loaded using L<File::KDBX::Loader::XML>, but you can use the +B<File::KDBX::Loader::Raw> loader to not parse the body at all and just get the raw body content. This can be +useful for debugging or creating KDBX files with arbitrary content (see L<File::KDBX::Dumper::Raw>). + +=cut diff --git a/lib/File/KDBX/Loader/V3.pm b/lib/File/KDBX/Loader/V3.pm new file mode 100644 index 0000000..68d7f9c --- /dev/null +++ b/lib/File/KDBX/Loader/V3.pm @@ -0,0 +1,164 @@ +package File::KDBX::Loader::V3; +# ABSTRACT: Load KDBX3 files + +# magic +# headers +# body +# CRYPT( +# start bytes +# HASH( +# COMPRESS( +# xml +# ) +# ) +# ) + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Encode qw(decode); +use File::KDBX::Constants qw(:header :compression :kdf); +use File::KDBX::Error; +use File::KDBX::Util qw(:io assert_64bit erase_scoped); +use PerlIO::via::File::KDBX::Crypt; +use PerlIO::via::File::KDBX::HashBlock; +use namespace::clean; + +use parent 'File::KDBX::Loader'; + +our $VERSION = '999.999'; # VERSION + +sub _read_header { + my $self = shift; + my $fh = shift; + + read_all $fh, my $buf, 3 or throw 'Malformed header field, expected header type and size'; + my ($type, $size) = unpack('C S<', $buf); + + my $val; + if (0 < $size) { + read_all $fh, $val, $size or throw 'Expected header value', type => $type, size => $size; + $buf .= $val; + } + + $type = KDBX_HEADER($type); + if ($type == HEADER_END) { + # done + } + elsif ($type == HEADER_COMMENT) { + $val = decode('UTF-8', $val); + } + elsif ($type == HEADER_CIPHER_ID) { + $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size; + } + elsif ($type == HEADER_COMPRESSION_FLAGS) { + $val = unpack('L<', $val); + } + elsif ($type == HEADER_MASTER_SEED) { + $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size; + } + elsif ($type == HEADER_TRANSFORM_SEED) { + # nothing + } + elsif ($type == HEADER_TRANSFORM_ROUNDS) { + assert_64bit; + $val = unpack('Q<', $val); + } + elsif ($type == HEADER_ENCRYPTION_IV) { + # nothing + } + elsif ($type == HEADER_INNER_RANDOM_STREAM_KEY) { + # nothing + } + elsif ($type == HEADER_STREAM_START_BYTES) { + # nothing + } + elsif ($type == HEADER_INNER_RANDOM_STREAM_ID) { + $val = unpack('L<', $val); + } + elsif ($type == HEADER_KDF_PARAMETERS || + $type == HEADER_PUBLIC_CUSTOM_DATA) { + throw "Unexpected KDBX4 header: $type", type => $type; + } + else { + alert "Unknown header: $type", type => $type; + } + + return wantarray ? ($type => $val, $buf) : $buf; +} + +sub _read_body { + my $self = shift; + my $fh = shift; + my $key = shift; + my $header_data = shift; + my $kdbx = $self->kdbx; + + # assert all required headers present + for my $field ( + HEADER_CIPHER_ID, + HEADER_ENCRYPTION_IV, + HEADER_MASTER_SEED, + HEADER_INNER_RANDOM_STREAM_KEY, + HEADER_STREAM_START_BYTES, + ) { + defined $kdbx->headers->{$field} or throw "Missing $field"; + } + + $kdbx->kdf_parameters({ + KDF_PARAM_UUID() => KDF_UUID_AES, + KDF_PARAM_AES_ROUNDS() => delete $kdbx->headers->{+HEADER_TRANSFORM_ROUNDS}, + KDF_PARAM_AES_SEED() => delete $kdbx->headers->{+HEADER_TRANSFORM_SEED}, + }); + + my $master_seed = $kdbx->headers->{+HEADER_MASTER_SEED}; + + my @cleanup; + $key = $kdbx->composite_key($key); + + my $response = $key->challenge($master_seed); + push @cleanup, erase_scoped $response; + + my $transformed_key = $kdbx->kdf->transform($key); + push @cleanup, erase_scoped $transformed_key; + + my $final_key = digest_data('SHA256', $master_seed, $response, $transformed_key); + push @cleanup, erase_scoped $final_key; + + my $cipher = $kdbx->cipher(key => $final_key); + PerlIO::via::File::KDBX::Crypt->push($fh, $cipher); + + read_all $fh, my $start_bytes, 32 or throw 'Failed to read starting bytes'; + + my $expected_start_bytes = $kdbx->headers->{stream_start_bytes}; + $start_bytes eq $expected_start_bytes + or throw "Invalid credentials or data is corrupt (wrong starting bytes)\n", + got => $start_bytes, expected => $expected_start_bytes, headers => $kdbx->headers; + + $kdbx->key($key); + + PerlIO::via::File::KDBX::HashBlock->push($fh); + + my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS}; + if ($compress == COMPRESSION_GZIP) { + require PerlIO::via::File::KDBX::Compression; + PerlIO::via::File::KDBX::Compression->push($fh); + } + elsif ($compress != COMPRESSION_NONE) { + throw "Unsupported compression ($compress)\n", compression_flags => $compress; + } + + $self->_read_inner_body($fh); + + binmode($fh, ':pop') if $compress; + binmode($fh, ':pop:pop'); + + if (my $header_hash = $kdbx->meta->{header_hash}) { + my $got_header_hash = digest_data('SHA256', $header_data); + $header_hash eq $got_header_hash + or throw 'Header hash does not match', got => $got_header_hash, expected => $header_hash; + } +} + +1; diff --git a/lib/File/KDBX/Loader/V4.pm b/lib/File/KDBX/Loader/V4.pm new file mode 100644 index 0000000..5148d12 --- /dev/null +++ b/lib/File/KDBX/Loader/V4.pm @@ -0,0 +1,265 @@ +package File::KDBX::Loader::V4; +# ABSTRACT: Load KDBX4 files + +# magic +# headers +# headers checksum +# headers hmac +# body +# HMAC( +# CRYPT( +# COMPRESS( +# xml +# ) +# ) +# ) + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Crypt::Mac::HMAC qw(hmac); +use Encode qw(decode); +use File::KDBX::Constants qw(:header :inner_header :variant_map :compression); +use File::KDBX::Error; +use File::KDBX::Util qw(:io assert_64bit erase_scoped); +use PerlIO::via::File::KDBX::Crypt; +use PerlIO::via::File::KDBX::HmacBlock; +use boolean; +use namespace::clean; + +use parent 'File::KDBX::Loader'; + +our $VERSION = '999.999'; # VERSION + +sub _read_header { + my $self = shift; + my $fh = shift; + + read_all $fh, my $buf, 5 or throw 'Malformed header field, expected header type and size'; + my ($type, $size) = unpack('C L<', $buf); + + my $val; + if (0 < $size) { + read_all $fh, $val, $size or throw 'Expected header value', type => $type, size => $size; + $buf .= $val; + } + + $type = KDBX_HEADER($type); + if ($type == HEADER_END) { + # done + } + elsif ($type == HEADER_COMMENT) { + $val = decode('UTF-8', $val); + } + elsif ($type == HEADER_CIPHER_ID) { + $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size; + } + elsif ($type == HEADER_COMPRESSION_FLAGS) { + $val = unpack('L<', $val); + } + elsif ($type == HEADER_MASTER_SEED) { + $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size; + } + elsif ($type == HEADER_ENCRYPTION_IV) { + # nothing + } + elsif ($type == HEADER_KDF_PARAMETERS) { + open(my $dict_fh, '<', \$val); + $val = $self->_read_variant_dictionary($dict_fh); + } + elsif ($type == HEADER_PUBLIC_CUSTOM_DATA) { + open(my $dict_fh, '<', \$val); + $val = $self->_read_variant_dictionary($dict_fh); + } + elsif ($type == HEADER_INNER_RANDOM_STREAM_ID || + $type == HEADER_INNER_RANDOM_STREAM_KEY || + $type == HEADER_TRANSFORM_SEED || + $type == HEADER_TRANSFORM_ROUNDS || + $type == HEADER_STREAM_START_BYTES) { + throw "Unexpected KDBX3 header: $type", type => $type; + } + else { + alert "Unknown header: $type", type => $type; + } + + return wantarray ? ($type => $val, $buf) : $buf; +} + +sub _read_variant_dictionary { + my $self = shift; + my $fh = shift; + + read_all $fh, my $buf, 2 or throw 'Failed to read variant dictionary version'; + my ($version) = unpack('S<', $buf); + VMAP_VERSION == ($version & VMAP_VERSION_MAJOR_MASK) + or throw 'Unsupported variant dictionary version', version => $version; + + my %dict; + + while (1) { + read_all $fh, $buf, 1 or throw 'Failed to read variant type'; + my ($type) = unpack('C', $buf); + last if $type == VMAP_TYPE_END; # terminating null + + read_all $fh, $buf, 4 or throw 'Failed to read variant key size'; + my ($klen) = unpack('L<', $buf); + + read_all $fh, my $key, $klen or throw 'Failed to read variant key'; + + read_all $fh, $buf, 4 or throw 'Failed to read variant size'; + my ($vlen) = unpack('L<', $buf); + + read_all $fh, my $val, $vlen or throw 'Failed to read variant'; + + if ($type == VMAP_TYPE_UINT32) { + ($val) = unpack('L<', $val); + } + elsif ($type == VMAP_TYPE_UINT64) { + assert_64bit; + ($val) = unpack('Q<', $val); + } + elsif ($type == VMAP_TYPE_BOOL) { + ($val) = unpack('C', $val); + $val = boolean($val); + } + elsif ($type == VMAP_TYPE_INT32) { + ($val) = unpack('l<', $val); + } + elsif ($type == VMAP_TYPE_INT64) { + assert_64bit; + ($val) = unpack('q<', $val); + } + elsif ($type == VMAP_TYPE_STRING) { + $val = decode('UTF-8', $val); + } + elsif ($type == VMAP_TYPE_BYTEARRAY) { + # nothing + } + else { + throw 'Unknown variant type', type => $type; + } + $dict{$key} = $val; + } + + return \%dict; +} + +sub _read_body { + my $self = shift; + my $fh = shift; + my $key = shift; + my $header_data = shift; + my $kdbx = $self->kdbx; + + # assert all required headers present + for my $field ( + HEADER_CIPHER_ID, + HEADER_ENCRYPTION_IV, + HEADER_MASTER_SEED, + ) { + defined $kdbx->headers->{$field} or throw "Missing $field"; + } + + my @cleanup; + + # checksum check + read_all $fh, my $header_hash, 32 or throw 'Failed to read header hash'; + my $got_header_hash = digest_data('SHA256', $header_data); + $got_header_hash eq $header_hash + or throw 'Data is corrupt (header checksum mismatch)', + got => $got_header_hash, expected => $header_hash; + + $key = $kdbx->composite_key($key); + my $transformed_key = $kdbx->kdf->transform($key); + push @cleanup, erase_scoped $transformed_key; + + # authentication check + read_all $fh, my $header_hmac, 32 or throw 'Failed to read header HMAC'; + my $hmac_key = digest_data('SHA512', $kdbx->headers->{master_seed}, $transformed_key, "\x01"); + push @cleanup, erase_scoped $hmac_key; + my $got_header_hmac = hmac('SHA256', + digest_data('SHA512', "\xff\xff\xff\xff\xff\xff\xff\xff", $hmac_key), + $header_data, + ); + $got_header_hmac eq $header_hmac + or throw "Invalid credentials or data is corrupt (header HMAC mismatch)\n", + got => $got_header_hmac, expected => $header_hmac; + + $kdbx->key($key); + + PerlIO::via::File::KDBX::HmacBlock->push($fh, $hmac_key); + + my $final_key = digest_data('SHA256', $kdbx->headers->{master_seed}, $transformed_key); + push @cleanup, erase_scoped $final_key; + + my $cipher = $kdbx->cipher(key => $final_key); + PerlIO::via::File::KDBX::Crypt->push($fh, $cipher); + + my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS}; + if ($compress == COMPRESSION_GZIP) { + require PerlIO::via::File::KDBX::Compression; + PerlIO::via::File::KDBX::Compression->push($fh); + } + elsif ($compress != COMPRESSION_NONE) { + throw "Unsupported compression ($compress)\n", compression_flags => $compress; + } + + $self->_read_inner_headers($fh); + $self->_read_inner_body($fh); + + binmode($fh, ':pop') if $compress; + binmode($fh, ':pop:pop'); +} + +sub _read_inner_headers { + my $self = shift; + my $fh = shift; + + while (my ($type, $val) = $self->_read_inner_header($fh)) { + last if $type == INNER_HEADER_END; + } +} + +sub _read_inner_header { + my $self = shift; + my $fh = shift; + my $kdbx = $self->kdbx; + + read_all $fh, my $buf, 1 or throw 'Expected inner header type'; + my ($type) = unpack('C', $buf); + + read_all $fh, $buf, 4 or throw 'Expected inner header size', type => $type; + my ($size) = unpack('L<', $buf); + + my $val; + if (0 < $size) { + read_all $fh, $val, $size or throw 'Expected inner header value', type => $type, size => $size; + } + + $type = KDBX_INNER_HEADER($type); + + if ($type == INNER_HEADER_END) { + # nothing + } + elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID) { + $val = unpack('L<', $val); + $kdbx->inner_headers->{$type} = $val; + } + elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY) { + $kdbx->inner_headers->{$type} = $val; + } + elsif ($type == INNER_HEADER_BINARY) { + my $msize = $size - 1; + my ($flags, $data) = unpack("C a$msize", $val); + my $id = scalar keys %{$kdbx->binaries}; + $kdbx->binaries->{$id} = { + value => $data, + $flags & INNER_HEADER_BINARY_FLAG_PROTECT ? (protect => true) : (), + }; + } + + return wantarray ? ($type => $val) : $type; +} + +1; diff --git a/lib/File/KDBX/Loader/XML.pm b/lib/File/KDBX/Loader/XML.pm new file mode 100644 index 0000000..43dd82a --- /dev/null +++ b/lib/File/KDBX/Loader/XML.pm @@ -0,0 +1,586 @@ +package File::KDBX::Loader::XML; +# ABSTRACT: Load unencrypted XML KeePass files + +use warnings; +use strict; + +use Crypt::Misc 0.029 qw(decode_b64); +use Encode qw(decode); +use File::KDBX::Constants qw(:version :time); +use File::KDBX::Error; +use File::KDBX::Safe; +use File::KDBX::Util qw(:text assert_64bit gunzip erase_scoped); +use Scalar::Util qw(looks_like_number); +use Time::Piece; +use XML::LibXML::Reader; +use boolean; +use namespace::clean; + +use parent 'File::KDBX::Loader'; + +our $VERSION = '999.999'; # VERSION + +sub _reader { $_[0]->{_reader} } + +sub _binaries { $_[0]->{binaries} //= {} } + +sub _safe { $_[0]->{safe} //= File::KDBX::Safe->new(cipher => $_[0]->kdbx->random_stream) } + +sub _read { + my $self = shift; + my $fh = shift; + + $self->_read_inner_body($fh); +} + +sub _read_inner_body { + my $self = shift; + my $fh = shift; + + # print do { local $/; <$fh> }; + # exit; + my $reader = $self->{_reader} = XML::LibXML::Reader->new(IO => $fh); + + delete $self->{safe}; + my $root_done; + + my $pattern = XML::LibXML::Pattern->new('/KeePassFile/Meta|/KeePassFile/Root'); + while ($reader->nextPatternMatch($pattern) == 1) { + next if $reader->nodeType != XML_READER_TYPE_ELEMENT; + my $name = $reader->localName; + if ($name eq 'Meta') { + $self->_read_xml_meta; + } + elsif ($name eq 'Root') { + if ($root_done) { + alert 'Ignoring extra Root element in KeePass XML file', line => $reader->lineNumber; + next; + } + $self->_read_xml_root; + $root_done = 1; + } + } + + if ($reader->readState == XML_READER_ERROR) { + throw 'Failed to parse KeePass XML'; + } + + $self->kdbx->_safe($self->_safe) if $self->{safe}; + + $self->_resolve_binary_refs; +} + +sub _read_xml_meta { + my $self = shift; + + $self->_read_xml_element($self->kdbx->meta, + Generator => 'text', + HeaderHash => 'binary', + DatabaseName => 'text', + DatabaseNameChanged => 'datetime', + DatabaseDescription => 'text', + DatabaseDescriptionChanged => 'datetime', + DefaultUserName => 'text', + DefaultUserNameChanged => 'datetime', + MaintenanceHistoryDays => 'number', + Color => 'text', + MasterKeyChanged => 'datetime', + MasterKeyChangeRec => 'number', + MasterKeyChangeForce => 'number', + MemoryProtection => \&_read_xml_memory_protection, + CustomIcons => \&_read_xml_custom_icons, + RecycleBinEnabled => 'bool', + RecycleBinUUID => 'uuid', + RecycleBinChanged => 'datetime', + EntryTemplatesGroup => 'uuid', + EntryTemplatesGroupChanged => 'datetime', + LastSelectedGroup => 'uuid', + LastTopVisibleGroup => 'uuid', + HistoryMaxItems => 'number', + HistoryMaxSize => 'number', + SettingsChanged => 'datetime', + Binaries => \&_read_xml_binaries, + CustomData => \&_read_xml_custom_data, + ); +} + +sub _read_xml_memory_protection { + my $self = shift; + my $meta = shift // $self->kdbx->meta; + + return $self->_read_xml_element( + ProtectTitle => 'bool', + ProtectUserName => 'bool', + ProtectPassword => 'bool', + ProtectURL => 'bool', + ProtectNotes => 'bool', + AutoEnableVisualHiding => 'bool', + ); +} + +sub _read_xml_binaries { + my $self = shift; + my $kdbx = $self->kdbx; + + my $binaries = $self->_read_xml_element( + Binary => sub { + my $self = shift; + my $id = $self->_read_xml_attribute('ID'); + my $compressed = $self->_read_xml_attribute('Compressed', 'bool', false); + my $protected = $self->_read_xml_attribute('Protected', 'bool', false); + my $data = $self->_read_xml_content('binary'); + + my $binary = { + value => $data, + $protected ? (protect => true) : (), + }; + + if ($protected) { + # if compressed, decompress later when the safe is unlocked + $self->_safe->add_protected($compressed ? \&gunzip : (), $binary); + } + elsif ($compressed) { + $binary->{value} = gunzip($data); + } + + $id => $binary; + }, + ); + + $kdbx->binaries({%{$kdbx->binaries}, %$binaries}); + return (); # do not add to meta +} + +sub _read_xml_custom_data { + my $self = shift; + + return $self->_read_xml_element( + Item => sub { + my $self = shift; + my $item = $self->_read_xml_element( + Key => 'text', + Value => 'text', + LastModificationTime => 'datetime', # KDBX4.1 + ); + $item->{key} => $item; + }, + ); +} + +sub _read_xml_custom_icons { + my $self = shift; + + return $self->_read_xml_element( + Icon => sub { + my $self = shift; + my $icon = $self->_read_xml_element( + UUID => 'uuid', + Data => 'binary', + Name => 'text', # KDBX4.1 + LastModificationTime => 'datetime', # KDBX4.1 + ); + $icon->{uuid} => $icon; + }, + ); +} + +sub _read_xml_root { + my $self = shift; + my $kdbx = $self->kdbx; + + my $root = $self->_read_xml_element( + Group => \&_read_xml_group, + DeletedObjects => \&_read_xml_deleted_objects, + ); + + $kdbx->deleted_objects($root->{deleted_objects}); + $kdbx->root($root->{group}) if $root->{group}; +} + +sub _read_xml_group { + my $self = shift; + + return $self->_read_xml_element({entries => [], groups => []}, + UUID => 'uuid', + Name => 'text', + Notes => 'text', + Tags => 'text', # KDBX4.1 + IconID => 'number', + CustomIconUUID => 'uuid', + Times => \&_read_xml_times, + IsExpanded => 'bool', + DefaultAutoTypeSequence => 'text', + EnableAutoType => 'tristate', + EnableSearching => 'tristate', + LastTopVisibleEntry => 'uuid', + CustomData => \&_read_xml_custom_data, # KDBX4 + PreviousParentGroup => 'uuid', # KDBX4.1 + Entry => [entries => \&_read_xml_entry], + Group => [groups => \&_read_xml_group], + ); +} + +sub _read_xml_entry { + my $self = shift; + + my $entry = $self->_read_xml_element({strings => [], binaries => []}, + UUID => 'uuid', + IconID => 'number', + CustomIconUUID => 'uuid', + ForegroundColor => 'text', + BackgroundColor => 'text', + OverrideURL => 'text', + Tags => 'text', + Times => \&_read_xml_times, + AutoType => \&_read_xml_entry_auto_type, + PreviousParentGroup => 'uuid', # KDBX4.1 + QualityCheck => 'bool', # KDBX4.1 + String => [strings => \&_read_xml_entry_string], + Binary => [binaries => \&_read_xml_entry_binary], + CustomData => \&_read_xml_custom_data, # KDBX4 + History => sub { + my $self = shift; + return $self->_read_xml_element([], + Entry => \&_read_xml_entry, + ); + }, + ); + + my %strings; + for my $string (@{$entry->{strings} || []}) { + $strings{$string->{key}} = $string->{value}; + } + $entry->{strings} = \%strings; + + my %binaries; + for my $binary (@{$entry->{binaries} || []}) { + $binaries{$binary->{key}} = $binary->{value}; + } + $entry->{binaries} = \%binaries; + + return $entry; +} + +sub _read_xml_times { + my $self = shift; + + return $self->_read_xml_element( + LastModificationTime => 'datetime', + CreationTime => 'datetime', + LastAccessTime => 'datetime', + ExpiryTime => 'datetime', + Expires => 'bool', + UsageCount => 'number', + LocationChanged => 'datetime', + ); +} + +sub _read_xml_entry_string { + my $self = shift; + + return $self->_read_xml_element( + Key => 'text', + Value => sub { + my $self = shift; + + my $protected = $self->_read_xml_attribute('Protected', 'bool', false); + my $protect_in_memory = $self->_read_xml_attribute('ProtectInMemory', 'bool', false); + my $protect = $protected || $protect_in_memory; + + my $val = $self->_read_xml_content($protected ? 'binary' : 'text'); + + my $string = { + value => $val, + $protect ? (protect => true) : (), + }; + + $self->_safe->add_protected(sub { decode('UTF-8', $_[0]) }, $string) if $protected; + + $string; + }, + ); +} + +sub _read_xml_entry_binary { + my $self = shift; + + return $self->_read_xml_element( + Key => 'text', + Value => sub { + my $self = shift; + + my $ref = $self->_read_xml_attribute('Ref'); + my $compressed = $self->_read_xml_attribute('Compressed', 'bool', false); + my $protected = $self->_read_xml_attribute('Protected', 'bool', false); + my $binary = {}; + + if (defined $ref) { + $binary->{ref} = $ref; + } + else { + $binary->{value} = $self->_read_xml_content('binary'); + $binary->{protect} = true if $protected; + + if ($protected) { + # if compressed, decompress later when the safe is unlocked + $self->_safe->add_protected($compressed ? \&gunzip : (), $binary); + } + elsif ($compressed) { + $binary->{value} = gunzip($binary->{value}); + } + } + + $binary; + }, + ); +} + +sub _read_xml_entry_auto_type { + my $self = shift; + + return $self->_read_xml_element({associations => []}, + Enabled => 'bool', + DataTransferObfuscation => 'number', + DefaultSequence => 'text', + Association => [associations => sub { + my $self = shift; + return $self->_read_xml_element( + Window => 'text', + KeystrokeSequence => 'text', + ); + }], + ); +} + +sub _read_xml_deleted_objects { + my $self = shift; + + return $self->_read_xml_element( + DeletedObject => sub { + my $self = shift; + my $object = $self->_read_xml_element( + UUID => 'uuid', + DeletionTime => 'datetime', + ); + $object->{uuid} => $object; + } + ); +} + +############################################################################## + +sub _resolve_binary_refs { + my $self = shift; + my $kdbx = $self->kdbx; + + my $entries = $kdbx->all_entries(history => 1); + my $pool = $kdbx->binaries; + + for my $entry (@$entries) { + while (my ($key, $binary) = each %{$entry->binaries}) { + my $ref = $binary->{ref} // next; + next if defined $binary->{value}; + + my $data = $pool->{$ref}; + if (!defined $data || !defined $data->{value}) { + alert "Found a reference to a missing binary: $key", key => $key, ref => $ref; + next; + } + $binary->{value} = $data->{value}; + $binary->{protect} = true if $data->{protect}; + delete $binary->{ref}; + } + } +} + +############################################################################## + +sub _read_xml_element { + my $self = shift; + my $args = @_ % 2 == 1 ? shift : {}; + my %spec = @_; + + my $reader = $self->_reader; + my $path = $reader->nodePath; + $path =~ s!\Q/text()\E$!!; + + return $args if $reader->isEmptyElement; + + my $store = ref $args eq 'CODE' ? $args + : ref $args eq 'HASH' ? sub { + my ($key, $val) = @_; + if (ref $args->{$key} eq 'HASH') { + $args->{$key}{$key} = $val; + } + elsif (ref $args->{$key} eq 'ARRAY') { + push @{$args->{$key}}, $val; + } + else { + exists $args->{$key} + and alert 'Overwriting value', node => $reader->nodePath, line => $reader->lineNumber; + $args->{$key} = $val; + } + } : ref $args eq 'ARRAY' ? sub { + my ($key, $val) = @_; + push @$args, $val; + } : sub {}; + + my $pattern = XML::LibXML::Pattern->new("${path}|${path}/*"); + while ($reader->nextPatternMatch($pattern) == 1) { + last if $reader->nodePath eq $path && $reader->nodeType == XML_READER_TYPE_END_ELEMENT; + next if $reader->nodeType != XML_READER_TYPE_ELEMENT; + + my $name = $reader->localName; + my $key = snakify($name); + my $type = $spec{$name}; + ($key, $type) = @$type if ref $type eq 'ARRAY'; + + if (!defined $type) { + exists $spec{$name} or alert "Ignoring unknown element: $name", + node => $reader->nodePath, + line => $reader->lineNumber; + next; + } + + if (ref $type eq 'CODE') { + my @result = $self->$type($args, $reader->nodePath); + if (@result == 2) { + $store->(@result); + } + elsif (@result == 1) { + $store->($key, @result); + } + } + else { + $store->($key, $self->_read_xml_content($type)); + } + } + + return $args; +} + +sub _read_xml_attribute { + my $self = shift; + my $name = shift; + my $type = shift // 'text'; + my $default = shift; + my $reader = $self->_reader; + + return $default if !$reader->hasAttributes; + + my $value = trim($reader->getAttribute($name)); + if (!defined $value) { + # try again after reading in all the attributes + $reader->moveToFirstAttribute; + while ($self->_reader->readAttributeValue == 1) {} + $reader->moveToElement; + + $value = trim($reader->getAttribute($name)); + } + + return $default if !defined $value; + + my $decoded = eval { _decode_primitive($value, $type) }; + if (my $err = $@) { + ref $err and $err->details(attribute => $name, node => $reader->nodePath, line => $reader->lineNumber); + throw $err + } + + return $decoded; +} + +sub _read_xml_content { + my $self = shift; + my $type = shift; + my $reader = $self->_reader; + + $reader->read if !$reader->isEmptyElement; # step into element + return '' if !$reader->hasValue; + + my $content = trim($reader->value); + + my $decoded = eval { _decode_primitive($content, $type) }; + if (my $err = $@) { + ref $err and $err->details(node => $reader->nodePath, line => $reader->lineNumber); + throw $err + } + + return $decoded; +} + +############################################################################## + +sub _decode_primitive { goto &{__PACKAGE__."::_decode_$_[1]"} } + +sub _decode_binary { + local $_ = shift; + return '' if !defined || (ref && !defined $$_); + $_ = eval { decode_b64(ref $_ ? $$_ : $_) }; + my $err = $@; + my $cleanup = erase_scoped $_; + $err and throw 'Failed to parse binary', error => $err; + return $_; +} + +sub _decode_bool { + local $_ = shift; + return true if /^True$/i; + return false if /^False$/i; + return false if length($_) == 0; + throw 'Expected boolean', text => $_; +} + +sub _decode_datetime { + local $_ = shift; + + if (/^[A-Za-z0-9\+\/\=]+$/) { + my $binary = eval { decode_b64($_) }; + if (my $err = $@) { + throw 'Failed to parse binary datetime', text => $_, error => $err; + } + throw $@ if $@; + assert_64bit; + $binary .= \0 x (8 - length($binary)) if length($binary) < 8; + my ($seconds_since_ad1) = unpack('Q<', $binary); + my $epoch = $seconds_since_ad1 - TIME_SECONDS_AD1_TO_UNIX_EPOCH; + return Time::Piece->new($epoch); + } + + + my $dt = eval { Time::Piece->strptime($_, '%Y-%m-%dT%H:%M:%SZ') }; + if (my $err = $@) { + throw 'Failed to parse datetime', text => $_, error => $err; + } + return $dt; +} + +sub _decode_tristate { + local $_ = shift; + return undef if /^null$/i; + my $tristate = eval { _decode_bool($_) }; + $@ and throw 'Expected tristate', text => $_, error => $@; + return $tristate; +} + +sub _decode_number { + local $_ = shift; + $_ = _decode_text($_); + looks_like_number($_) or throw 'Expected number', text => $_; + return $_+0; +} + +sub _decode_text { + local $_ = shift; + return '' if !defined; + return $_; +} + +sub _decode_uuid { + local $_ = shift; + my $uuid = eval { _decode_binary($_) }; + $@ and throw 'Expected UUID', text => $_, error => $@; + length($uuid) == 16 or throw 'Invalid UUID size', size => length($uuid); + return $uuid; +} + +1; diff --git a/lib/File/KDBX/Object.pm b/lib/File/KDBX/Object.pm new file mode 100644 index 0000000..09c790f --- /dev/null +++ b/lib/File/KDBX/Object.pm @@ -0,0 +1,418 @@ +package File::KDBX::Object; +# ABSTRACT: A KDBX database object + +use warnings; +use strict; + +use Devel::GlobalDestruction; +use File::KDBX::Error; +use File::KDBX::Util qw(:uuid); +use Ref::Util qw(is_arrayref is_plain_hashref is_ref); +use Scalar::Util qw(blessed refaddr weaken); +use namespace::clean; + +our $VERSION = '999.999'; # VERSION + +my %KDBX; + +=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); + +Construct a new KDBX object. + +There is a subtlety to take note of. There is a significant difference between: + + File::KDBX::Entry->new(username => 'iambatman'); + +and: + + File::KDBX::Entry->new({username => 'iambatman'}); # WRONG + +In the first, an empty entry is first created and then initialized with whatever I<attributes> 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<Entry>, +whereas with the first the attributes will set the structure in the correct way (just like using the entry +object accessors / getters / setters). + +The second example isn't I<generally> 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 +C<< {username => $str} >> isn't a valid raw KDBX entry object. The L</username> attribute is really a proxy +for the C<UserName> string, so the equivalent raw entry object should be +C<< {strings => {UserName => {value => $str}}} >>. These are roughly equivalent: + + File::KDBX::Entry->new(username => 'iambatman'); + File::KDBX::Entry->new({strings => {UserName => {value => 'iambatman'}}}); + +If this explanation went over your head, that's fine. Just stick with the attributes since they are typically +easier to use correctly and provide the most convenience. If in the future you think of some kind of KDBX +object manipulation you want to do that isn't supported by the accessors and methods, just know you I<can> +access an object's data directly. + +=cut + +sub new { + my $class = shift; + + # copy constructor + return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class); + + my $data; + $data = shift if is_plain_hashref($_[0]); + + my $kdbx; + $kdbx = shift if @_ % 2 == 1; + + my %args = @_; + $args{kdbx} //= $kdbx if defined $kdbx; + + my $self = bless $data // {}, $class; + $self->init(%args); + $self->_set_default_attributes if !$data; + return $self; +} + +sub init { + my $self = shift; + my %args = @_; + + while (my ($key, $val) = each %args) { + if (my $method = $self->can($key)) { + $self->$method($val); + } + } + + return $self; +} + +sub DESTROY { + return if in_global_destruction; + my $self = shift; + delete $KDBX{refaddr($self)}; +} + +=method wrap + + $object = File::KDBX::Object->wrap($object); + +Ensure that a KDBX object is blessed. + +=cut + +sub wrap { + 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, @_); +} + +=method label + + $label = $object->label; + $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. + +=cut + +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 +get different effects: + +=for :list +* C<new_uuid> - 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<parent>) +* C<parent> - If set, add the copy to the same parent (default: false) +* C<relabel> - If set, change the name or title of the copy to "C<$original_title> - Copy". +* C<entries> - Toggle whether or not to copy child entries, if any (default: true) +* C<groups> - Toggle whether or not to copy child groups, if any (default: true) +* C<history> - Toggle whether or not to copy the entry history, if any (default: true) +* C<reference_password> - Toggle whether or not cloned entry's Password string should be set to a reference to + their original entry's Password string. +* C<reference_username> - Toggle whether or not cloned entry's UserName string should be set to a reference to + their original entry's UserName string. + +=cut + +my %CLONE = (entries => 1, groups => 1, history => 1); +sub clone { + my $self = shift; + my %args = @_; + + local $CLONE{new_uuid} = $args{new_uuid} // $args{parent} // 0; + local $CLONE{entries} = $args{entries} // 1; + local $CLONE{groups} = $args{groups} // 1; + local $CLONE{history} = $args{history} // 1; + local $CLONE{reference_password} = $args{reference_password} // 0; + local $CLONE{reference_username} = $args{reference_username} // 0; + + require Storable; + my $copy = Storable::dclone($self); + + if ($args{relabel} and my $label = $self->label) { + $copy->label("$label - Copy"); + } + if ($args{parent} and my $parent = $self->parent) { + $parent->add_object($copy); + } + + return $copy; +} + +sub STORABLE_freeze { + my $self = shift; + my $cloning = shift; + + my $copy = {%$self}; + delete $copy->{entries} if !$CLONE{entries}; + delete $copy->{groups} if !$CLONE{groups}; + delete $copy->{history} if !$CLONE{history}; + + return refaddr($self) || '', $copy; +} + +sub STORABLE_thaw { + my $self = shift; + my $cloning = shift; + my $addr = shift; + my $clone = shift; + + @$self{keys %$clone} = values %$clone; + + my $kdbx = $KDBX{$addr}; + $self->kdbx($kdbx) if $kdbx; + + if ($self->{uuid}) { + if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->isa('File::KDBX::Entry')) { + my $uuid = format_uuid($self->{uuid}); + my $clone_obj = do { + local $CLONE{new_uuid} = 0; + local $CLONE{entries} = 1; + local $CLONE{groups} = 1; + local $CLONE{history} = 1; + local $CLONE{reference_password} = 0; + local $CLONE{reference_username} = 0; + bless Storable::dclone({%$clone}), 'File::KDBX::Entry'; + }; + my $txn = $self->begin_work($clone_obj); + if ($CLONE{reference_password}) { + $self->password("{REF:P\@I:$uuid}"); + } + if ($CLONE{reference_username}) { + $self->username("{REF:U\@I:$uuid}"); + } + $txn->commit; + } + $self->uuid(generate_uuid) if $CLONE{new_uuid}; + } +} + +=attr kdbx + + $kdbx = $object->kdbx; + $object->kdbx($kdbx); + +Get or set the L<File::KDBX> instance associated with this object. + +=cut + +sub kdbx { + my $self = shift; + $self = $self->new if !ref $self; + my $addr = refaddr($self); + if (@_) { + $KDBX{$addr} = shift; + if (defined $KDBX{$addr}) { + weaken $KDBX{$addr}; + } + else { + delete $KDBX{$addr}; + } + } + $KDBX{$addr} or throw 'Object is disassociated from a KDBX database', object => $self; +} + +=method id + + $string_uuid = $object->id; + $string_uuid = $object->id($delimiter); + +Get the unique identifier for this object as a B<formatted> UUID string, typically for display purposes. You +could use this to compare with other identifiers formatted with the same delimiter, but it is more efficient +to use the raw UUID for that purpose (see L</uuid>). + +A delimiter can optionally be provided to break up the UUID string visually. See +L<File::KDBX::Util/format_uuid>. + +=cut + +sub id { format_uuid(shift->uuid, @_) } + +=method group + + $group = $object->group; + +Get the parent group to which an object belongs or C<undef> if it belongs to no group. + +Alias: C<parent> + +=cut + +sub group { + my $self = shift; + my $lineage = $self->kdbx->trace_lineage($self) or return; + return pop @$lineage; +} + +sub parent { shift->group(@_) } + +=method remove + + $object = $object->remove; + +Remove the object from the database. If the object is a group, all contained objects are removed as well. + +=cut + +sub remove { + my $self = shift; + my $parent = $self->parent; + $parent->remove_object($self) if $parent; + return $self; +} + +=method tag_list + + @tags = $entry->tag_list; + +Get a list of tags, split from L</tag> using delimiters C<,>, C<.>, C<:>, C<;> and whitespace. + +=cut + +sub tag_list { + my $self = shift; + return grep { $_ ne '' } split(/[,\.:;]|\s+/, trim($self->tags) // ''); +} + +=method custom_icon + + $image_data = $object->custom_icon; + $image_data = $object->custom_icon($image_data, %attributes); + +Get or set an icon image. Returns C<undef> if there is no custom icon set. Setting a custom icon will change +the L</custom_icon_uuid> attribute. + +Custom icon attributes (supported in KDBX4.1 and greater): + +=for :list +* C<name> - Name of the icon (text) +* C<last_modification_time> - Just what it says (datetime) + +=cut + +sub custom_icon { + my $self = shift; + my $kdbx = $self->kdbx; + if (@_) { + my $img = shift; + my $uuid = defined $img ? $kdbx->add_custom_icon($img, @_) : undef; + $self->icon_id(0) if $uuid; + $self->custom_icon_uuid($uuid); + return $img; + } + return $kdbx->custom_icon_data($self->custom_icon_uuid); +} + +=method custom_data + + \%all_data = $object->custom_data; + $object->custom_data(\%all_data); + + \%data = $object->custom_data($key); + $object->custom_data($key => \%data); + $object->custom_data(%data); + $object->custom_data(key => $value, %data); + +Get and set custom data. Custom data is metadata associated with an object. + +Each data item can have a few attributes associated with it. + +=for :list +* C<key> - A unique text string identifier used to look up the data item (required) +* C<value> - A text string value (required) +* C<last_modification_time> (optional, KDBX4.1+) + +=cut + +sub custom_data { + my $self = shift; + $self->{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]); + return $self->{custom_data} //= {} if !@_; + + my %args = @_ == 2 ? (key => shift, value => shift) + : @_ % 2 == 1 ? (key => shift, @_) : @_; + + if (!$args{key} && !$args{value}) { + my %standard = (key => 1, value => 1, last_modification_time => 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 = $args{key} or throw 'Must provide a custom_data key to access'; + + return $self->{custom_data}{$key} = $args{value} if is_plain_hashref($args{value}); + + while (my ($field, $value) = each %args) { + $self->{custom_data}{$key}{$field} = $value; + } + return $self->{custom_data}{$key}; +} + +=method custom_data_value + + $value = $object->custom_data_value($key); + +Exactly the same as L</custom_data> except returns just the custom data's value rather than a structure of +attributes. This is a shortcut for: + + my $data = $object->custom_data($key); + my $value = defined $data ? $data->{value} : undef; + +=cut + +sub custom_data_value { + my $self = shift; + my $data = $self->custom_data(@_) // return undef; + return $data->{value}; +} + +1; +__END__ + +=head1 DESCRIPTION + +KDBX is an object database. This abstract class represents an object. You should not use this class directly +but instead use its subclasses: + +=for :list +* L<File::KDBX::Entry> +* L<File::KDBX::Group> + +There is some functionality shared by both types of objects, and that's what this class provides. + +=cut diff --git a/lib/File/KDBX/Safe.pm b/lib/File/KDBX/Safe.pm new file mode 100644 index 0000000..24a3cf4 --- /dev/null +++ b/lib/File/KDBX/Safe.pm @@ -0,0 +1,300 @@ +package File::KDBX::Safe; +# ABSTRACT: Keep strings encrypted while in memory + +use warnings; +use strict; + +use Crypt::PRNG qw(random_bytes); +use Devel::GlobalDestruction; +use Encode qw(encode decode); +use File::KDBX::Constants qw(:random_stream); +use File::KDBX::Error; +use File::KDBX::Util qw(erase erase_scoped); +use Ref::Util qw(is_arrayref is_coderef is_hashref is_scalarref); +use Scalar::Util qw(refaddr); +use namespace::clean; + +our $VERSION = '999.999'; # VERSION + +=method new + + $safe = File::KDBX::Safe->new(%attributes); + $safe = File::KDBX::Safe->new(\@strings, %attributes); + +Create a new safe for storing secret strings encrypted in memory. + +If a cipher is passed, its stream will be reset. + +=cut + +sub new { + my $class = shift; + my %args = @_ % 2 == 0 ? @_ : (strings => shift, @_); + + if (!$args{cipher} && $args{key}) { + require File::KDBX::Cipher; + $args{cipher} = File::KDBX::Cipher->new(stream_id => STREAM_ID_CHACHA20, key => $args{key}); + } + + my $self = bless \%args, $class; + $self->cipher->finish; + $self->{counter} = 0; + + my $strings = delete $args{strings}; + $self->{items} = []; + $self->{index} = {}; + $self->add($strings) if $strings; + + return $self; +} + +sub DESTROY { !in_global_destruction and $_[0]->unlock } + +=method clear + + $safe->clear; + +Clear a safe, removing all store contents permanently. + +=cut + +sub clear { + my $self = shift; + $self->{items} = []; + $self->{index} = {}; + $self->{counter} = 0; + return $self; +} + +=method add + + $safe = $safe->lock(@strings); + $safe = $safe->lock(\@strings); + +Add strings to be encrypted. + +Alias: C<lock> + +=cut + +sub lock { shift->add(@_) } + +sub add { + my $self = shift; + my @strings = map { is_arrayref($_) ? @$_ : $_ } @_; + + @strings or throw 'Must provide strings to lock'; + + my $cipher = $self->cipher; + + for my $string (@strings) { + my $item = {str => $string, off => $self->{counter}}; + if (is_scalarref($string)) { + next if !defined $$string; + $item->{enc} = 'UTF-8' if utf8::is_utf8($$string); + if (my $encoding = $item->{enc}) { + my $encoded = encode($encoding, $$string); + $item->{val} = $cipher->crypt(\$encoded); + erase $encoded; + } + else { + $item->{val} = $cipher->crypt($string); + } + erase $string; + } + elsif (is_hashref($string)) { + next if !defined $string->{value}; + $item->{enc} = 'UTF-8' if utf8::is_utf8($string->{value}); + if (my $encoding = $item->{enc}) { + my $encoded = encode($encoding, $string->{value}); + $item->{val} = $cipher->crypt(\$encoded); + erase $encoded; + } + else { + $item->{val} = $cipher->crypt(\$string->{value}); + } + erase \$string->{value}; + } + else { + throw 'Safe strings must be a hashref or stringref', type => ref $string; + } + push @{$self->{items}}, $item; + $self->{index}{refaddr($string)} = $item; + $self->{counter} += length($item->{val}); + } + + return $self; +} + +=method add_protected + + $safe = $safe->add_protected(@strings); + $safe = $safe->add_protected(\@strings); + +Add strings that are already encrypted. + +B<WARNING:> 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 add_protected { + my $self = shift; + my $filter = is_coderef($_[0]) ? shift : undef; + my @strings = map { is_arrayref($_) ? @$_ : $_ } @_; + + @strings or throw 'Must provide strings to lock'; + + for my $string (@strings) { + my $item = {str => $string}; + $item->{filter} = $filter if defined $filter; + if (is_scalarref($string)) { + next if !defined $$string; + $item->{val} = $$string; + erase $string; + } + elsif (is_hashref($string)) { + next if !defined $string->{value}; + $item->{val} = $string->{value}; + erase \$string->{value}; + } + else { + throw 'Safe strings must be a hashref or stringref', type => ref $string; + } + push @{$self->{items}}, $item; + $self->{index}{refaddr($string)} = $item; + $self->{counter} += length($item->{val}); + } + + return $self; +} + +=method unlock + + $safe = $safe->unlock; + +Decrypt all the strings. Each stored string is set to its original value. + +This happens automatically when the safe is garbage-collected. + +=cut + +sub unlock { + my $self = shift; + + my $cipher = $self->cipher; + $cipher->finish; + $self->{counter} = 0; + + for my $item (@{$self->{items}}) { + my $string = $item->{str}; + my $cleanup = erase_scoped \$item->{val}; + my $str_ref; + if (is_scalarref($string)) { + $$string = $cipher->crypt(\$item->{val}); + if (my $encoding = $item->{enc}) { + my $decoded = decode($encoding, $string->{value}); + erase $string; + $$string = $decoded; + } + $str_ref = $string; + } + elsif (is_hashref($string)) { + $string->{value} = $cipher->crypt(\$item->{val}); + if (my $encoding = $item->{enc}) { + my $decoded = decode($encoding, $string->{value}); + erase \$string->{value}; + $string->{value} = $decoded; + } + $str_ref = \$string->{value}; + } + else { + die 'Unexpected'; + } + if (my $filter = $item->{filter}) { + my $filtered = $filter->($$str_ref); + erase $str_ref; + $$str_ref = $filtered; + } + } + + return $self->clear; +} + +=method peek + + $string_value = $safe->peek($string); + ... + erase $string_value; + +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. + +=cut + +sub peek { + my $self = shift; + my $string = shift; + + my $item = $self->{index}{refaddr($string)} // return; + + my $cipher = $self->cipher->dup(offset => $item->{off}); + + my $value = $cipher->crypt(\$item->{val}); + if (my $encoding = $item->{enc}) { + my $decoded = decode($encoding, $value); + erase $value; + return $decoded; + } + return $value; +} + +=attr cipher + + $cipher = $safe->cipher; + +Get the L<File::KDBX::Cipher::Stream> protecting a safe. + +=cut + +sub cipher { + my $self = shift; + $self->{cipher} //= do { + require File::KDBX::Cipher; + File::KDBX::Cipher->new(stream_id => STREAM_ID_CHACHA20, key => random_bytes(64)); + }; +} + +1; +__END__ + +=head1 SYNOPSIS + + use File::KDBX::Safe; + + $safe = File::KDBX::Safe->new; + + my $msg = 'Secret text'; + $safe->add(\$msg); + # $msg is now undef, the original message no longer in RAM + + my $obj = { value => 'Also secret' }; + $safe->add($obj); + # $obj is now { value => undef } + + say $safe->peek($msg); # Secret text + + $safe->unlock; + say $msg; # Secret text + say $obj->{value}; # Also secret + +=head1 DESCRIPTION + +This module provides memory protection functionality. It keeps strings encrypted in memory and decrypts them +as-needed. Encryption and decryption is done using a L<File::KDBX::Cipher::Stream>. + +A safe can protect one or more (possibly many) strings. When a string is added to a safe, it gets added to an +internal list so it will be decrypted when the entire safe is unlocked. + +=cut diff --git a/lib/File/KDBX/Transaction.pm b/lib/File/KDBX/Transaction.pm new file mode 100644 index 0000000..10e8b3f --- /dev/null +++ b/lib/File/KDBX/Transaction.pm @@ -0,0 +1,47 @@ +package File::KDBX::Transaction; +# ABSTRACT: Make multiple database edits atomically + +use warnings; +use strict; + +use Devel::GlobalDestruction; +use namespace::clean; + +our $VERSION = '999.999'; # VERSION + +sub new { + my $class = shift; + my $object = shift; + my $orig = shift // $object->clone; + return bless {object => $object, original => $orig}, $class; +} + +sub DESTROY { !in_global_destruction and $_[0]->rollback } + +sub object { $_[0]->{object} } +sub original { $_[0]->{original} } + +sub commit { + my $self = shift; + my $obj = $self->object; + if (my $commit = $obj->can('_commit')) { + $commit->($obj, $self); + } + $self->{committed} = 1; + return $obj; +} + +sub rollback { + my $self = shift; + return if $self->{committed}; + + my $obj = $self->object; + my $orig = $self->original; + + %$obj = (); + @$obj{keys %$orig} = values %$orig; + + return $obj; +} + +1; diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm new file mode 100644 index 0000000..2d83074 --- /dev/null +++ b/lib/File/KDBX/Util.pm @@ -0,0 +1,945 @@ +package File::KDBX::Util; +# ABSTRACT: Utility functions for working with KDBX files + +use warnings; +use strict; + +use Crypt::PRNG qw(random_bytes random_string); +use Encode qw(decode encode); +use Exporter qw(import); +use File::KDBX::Error; +use List::Util 1.33 qw(any all); +use Module::Load; +use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref is_ref); +use Scalar::Util qw(blessed isdual looks_like_number readonly refaddr); +use namespace::clean -except => 'import'; + +our $VERSION = '999.999'; # VERSION + +our %EXPORT_TAGS = ( + assert => [qw(assert_64bit)], + clone => [qw(clone clone_nomagic)], + crypt => [qw(pad_pkcs7)], + debug => [qw(dumper)], + fork => [qw(can_fork)], + function => [qw(memoize recurse_limit)], + empty => [qw(empty nonempty)], + erase => [qw(erase erase_scoped)], + gzip => [qw(gzip gunzip)], + io => [qw(read_all)], + load => [qw(load_optional load_xs try_load_optional)], + search => [qw(query search simple_expression_query)], + text => [qw(snakify trim)], + uuid => [qw(format_uuid generate_uuid is_uuid uuid)], + uri => [qw(split_url uri_escape_utf8 uri_unescape_utf8)], +); + +$EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS]; +our @EXPORT_OK = @{$EXPORT_TAGS{all}}; + +my %OPS = ( + 'eq' => 2, # binary + 'ne' => 2, + 'lt' => 2, + 'gt' => 2, + 'le' => 2, + 'ge' => 2, + '==' => 2, + '!=' => 2, + '<' => 2, + '>' => 2, + '<=' => 2, + '>=' => 2, + '=~' => 2, + '!~' => 2, + '!' => 1, # unary + '!!' => 1, + '-not' => 1, # special + '-false' => 1, + '-true' => 1, + '-defined' => 1, + '-undef' => 1, + '-empty' => 1, + '-nonempty' => 1, + '-or' => -1, + '-and' => -1, +); +my %OP_NEG = ( + 'eq' => 'ne', + 'ne' => 'eq', + 'lt' => 'ge', + 'gt' => 'le', + 'le' => 'gt', + 'ge' => 'lt', + '==' => '!=', + '!=' => '==', + '<' => '>=', + '>' => '<=', + '<=' => '>', + '>=' => '<', + '=~' => '!~', + '!~' => '=~', +); + +=func assert_64bit + + assert_64bit(); + +Throw if perl doesn't support 64-bit IVs. + +=cut + +sub assert_64bit() { + require Config; + $Config::Config{ivsize} < 8 + and throw "64-bit perl is required to use this feature.\n", ivsize => $Config::Config{ivsize}; +} + +=func can_fork + + $bool = can_fork; + +Determine if perl can fork, with logic lifted from L<Test2::Util/CAN_FORK>. + +=cut + +sub can_fork { + require Config; + return 1 if $Config::Config{d_fork}; + return 0 if $^O ne 'MSWin32' && $^O ne 'NetWare'; + return 0 if !$Config::Config{useithreads}; + return 0 if $Config::Config{ccflags} !~ /-DPERL_IMPLICIT_SYS/; + return 0 if $] < 5.008001; + if ($] == 5.010000 && $Config::Config{ccname} eq 'gcc' && $Config::Config{gccversion}) { + return 0 if $Config::Config{gccversion} !~ m/^(\d+)\.(\d+)/; + my @parts = split(/[\.\s]+/, $Config::Config{gccversion}); + return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8); + } + return 0 if $INC{'Devel/Cover.pm'}; + return 1; +} + +=func clone_nomagic + + $clone = clone_nomagic($thing); + +Clone deeply without keeping [most of] the magic. + +B<NOTE:> At the moment the implementation is naïve and won't respond well to nontrivial data. + +=cut + +sub clone { + require Storable; + goto &Storable::dclone; +} + +sub clone_nomagic { + my $thing = shift; + if (is_arrayref($thing)) { + my @arr = map { clone_nomagic($_) } @$thing; + return \@arr; + } + elsif (is_hashref($thing)) { + my %hash; + $hash{$_} = clone_nomagic($thing->{$_}) for keys %$thing; + return \%hash; + } + elsif (is_ref($thing)) { + return clone($thing); + } + return $thing; +} + +=func dumper + + $str = dumper $struct; + +Like L<Data::Dumper> but slightly terser in some cases relevent to L<File::KDBX>. + +=cut + +sub dumper { + require Data::Dumper; + # avoid "once" warnings + local $Data::Dumper::Deepcopy = $Data::Dumper::Deepcopy = 1; + local $Data::Dumper::Deparse = $Data::Dumper::Deparse = 1; + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Trailingcomma = 1; + local $Data::Dumper::Useqq = 1; + + my @dumps; + for my $struct (@_) { + my $str = Data::Dumper::Dumper($struct); + + # boolean + $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs; + # Time::Piece + $str =~ s/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \)/Time::Piece->new($1)/gs; + + print STDERR $str if !defined wantarray; + push @dumps, $str; + return $str; + } + return join("\n", @dumps); +} + +=func empty + +=func nonempty + + $bool = empty $thing; + + $bool = nonempty $thing; + +Test whether a thing is empty (or nonempty). An empty thing is one of these: + +=for :list +* nonexistent +* C<undef> +* zero-length string +* zero-length array +* hash with zero keys +* reference to an empty thing (recursive) + +Note in particular that zero C<0> is not considered empty because it is an actual value. + +=cut + +sub empty { _empty(@_) } +sub nonempty { !_empty(@_) } + +sub _empty { + return 1 if @_ == 0; + local $_ = shift; + return !defined $_ + || $_ eq '' + || (is_arrayref($_) && @$_ == 0) + || (is_hashref($_) && keys %$_ == 0) + || (is_scalarref($_) && (!defined $$_ || $$_ eq '')) + || (is_refref($_) && _empty($$_)); +} + +=func erase + + erase($string, ...); + erase(\$string, ...); + +Overwrite the memory used by one or more string. + +=cut + +# use File::KDBX::XS; + +sub erase { + # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just + # creating a copy and erasing the copy. + # TODO - Is this worth doing? Need some benchmarking. + for (@_) { + if (!is_ref($_)) { + next if !defined $_ || readonly $_; + if (USE_COWREFCNT()) { + my $cowrefcnt = B::COW::cowrefcnt($_); + goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt; + } + # if (__PACKAGE__->can('erase_xs')) { + # erase_xs($_); + # } + # else { + substr($_, 0, length($_), "\0" x length($_)); + # } + FREE_NONREF: { + no warnings 'uninitialized'; + undef $_; + } + } + elsif (is_scalarref($_)) { + next if !defined $$_ || readonly $$_; + if (USE_COWREFCNT()) { + my $cowrefcnt = B::COW::cowrefcnt($$_); + goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt; + } + # if (__PACKAGE__->can('erase_xs')) { + # erase_xs($$_); + # } + # else { + substr($$_, 0, length($$_), "\0" x length($$_)); + # } + FREE_REF: { + no warnings 'uninitialized'; + undef $$_; + } + } + elsif (is_arrayref($_)) { + erase(@$_); + @$_ = (); + } + elsif (is_hashref($_)) { + erase(values %$_); + %$_ = (); + } + else { + throw 'Cannot erase this type of scalar', type => ref $_, what => $_; + } + } +} + +=func erase_scoped + + $scope_guard = erase_scoped($string, ...); + $scope_guard = erase_scoped(\$string, ...); + undef $scope_guard; # erase happens here + +Get a scope guard that will cause scalars to be erased later (i.e. when the scope ends). This is useful if you +want to make sure a string gets erased after you're done with it, even if the scope ends abnormally. + +See L</erase>. + +=cut + +sub erase_scoped { + my @args; + for (@_) { + !is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_) + or throw 'Cannot erase this type of scalar', type => ref $_, what => $_; + push @args, is_ref($_) ? $_ : \$_; + } + require Scope::Guard; + return Scope::Guard->new(sub { erase(@args) }); +} + +=func format_uuid + + $string_uuid = format_uuid($raw_uuid); + $string_uuid = format_uuid($raw_uuid, $delimiter); + +Format a 128-bit UUID (given as a string of 16 octets) into a hexidecimal string, optionally with a delimiter +to break up the UUID visually into five parts. Examples: + + my $uuid = uuid('01234567-89AB-CDEF-0123-456789ABCDEF'); + say format_uuid($uuid); # -> 0123456789ABCDEF0123456789ABCDEF + say format_uuid($uuid, '-'); # -> 01234567-89AB-CDEF-0123-456789ABCDEF + +This is the inverse of L</uuid>. + +=cut + +sub format_uuid { + local $_ = shift // "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; + my $delim = shift // ''; + length($_) == 16 or throw 'Must provide a 16-bytes UUID', size => length($_), str => $_; + return uc(join($delim, unpack('H8 H4 H4 H4 H12', $_))); +} + +=func generate_uuid + + $uuid = generate_uuid; + $uuid = generate_uuid(\%set); + $uuid = generate_uuid(\&test_uuid); + +Generate a new random UUID. It's pretty unlikely that this will generate a repeat, but if you're worried about +that you can provide either a set of existing UUIDs (as a hashref where the keys are the elements of a set) or +a function to check for existing UUIDs, and this will be sure to not return a UUID already in provided set. +Perhaps an example will make it clear: + + my %uuid_set = ( + uuid('12345678-9ABC-DEFG-1234-56789ABCDEFG') => 'whatever', + ); + $uuid = generate_uuid(\%uuid_set); + # OR + $uuid = generate_uuid(sub { !$uuid_set{$_} }); + +Here, C<$uuid> can't be "12345678-9ABC-DEFG-1234-56789ABCDEFG". This example uses L</uuid> to easily pack +a 16-byte UUID from a literal, but it otherwise is not a consequential part of the example. + +=cut + +sub generate_uuid { + my $set = @_ % 2 == 1 ? shift : undef; + my %args = @_; + my $test = $set //= $args{test}; + $test = sub { !$set->{$_} } if is_hashref($test); + $test //= sub { 1 }; + my $printable = $args{printable} // $args{print}; + local $_ = ''; + do { + $_ = $printable ? random_string(16) : random_bytes(16); + } while (!$test->($_)); + return $_; +} + +=func gunzip + + $unzipped = gunzip($string); + +Decompress an octet stream. + +=cut + +sub gunzip { + load_optional('Compress::Raw::Zlib'); + local $_ = shift; + my ($i, $status) = Compress::Raw::Zlib::Inflate->new(-WindowBits => 31); + $status == Compress::Raw::Zlib::Z_OK() + or throw 'Failed to initialize compression library', status => $status; + $status = $i->inflate($_, my $out); + $status == Compress::Raw::Zlib::Z_STREAM_END() + or throw 'Failed to decompress data', status => $status; + return $out; +} + +=func gunzip + + $zipped = gzip($string); + +Compress an octet stream. + +=cut + +sub gzip { + load_optional('Compress::Raw::Zlib'); + local $_ = shift; + my ($d, $status) = Compress::Raw::Zlib::Deflate->new(-WindowBits => 31, -AppendOutput => 1); + $status == Compress::Raw::Zlib::Z_OK() + or throw 'Failed to initialize compression library', status => $status; + $status = $d->deflate($_, my $out); + $status == Compress::Raw::Zlib::Z_OK() + or throw 'Failed to compress data', status => $status; + $status = $d->flush($out); + $status == Compress::Raw::Zlib::Z_OK() + or throw 'Failed to compress data', status => $status; + return $out; +} + +=func is_uuid + + $bool = is_uuid($thing); + +Check if a thing is a UUID (i.e. scalar string of length 16). + +=cut + +sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 } + +=func load_optional + + $package = load_optional($package); + +Load a module that isn't required but can provide extra functionality. Throw if the module is not available. + +=cut + +sub load_optional { + for my $module (@_) { + eval { load $module }; + if (my $err = $@) { + warn $err if $ENV{DEBUG}; + throw "Missing dependency: Please install $module to use this feature.\n", module => $module; + } + } + return wantarray ? @_ : $_[0]; +} + +=func load_xs + + $bool = load_xs(); + $bool = load_xs($version); + +Attempt to load L<File::KDBX::XS>. Return truthy if C<XS> is loaded. If C<$version> is given, it will check +that at least the given version is loaded. + +=cut + +sub load_xs { + my $version = shift; + + require File::KDBX; + + my $has_xs = File::KDBX->can('XS_LOADED'); + return $has_xs->() && ($version ? eval { File::KDBX::XS->VERSION($version); 1 } : 1) if $has_xs; + + my $try_xs = 1; + $try_xs = 0 if $ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS}); + + my $use_xs = 0; + $use_xs = try_load_optional('File::KDBX::XS') if $try_xs; + + *File::KDBX::XS_LOADED = *File::KDBX::XS_LOADED = $use_xs ? sub() { 1 } : sub() { 0 }; + return $version ? eval { File::KDBX::XS->VERSION($version); 1 } : 1; +} + +=func memoize + + \&memoized_code = memoize(\&code, ...); + +Memoize a function. Extra arguments are passed through to C<&code> when it is called. + +=cut + +sub memoize { + my $func = shift; + my @args = @_; + my %cache; + return sub { $cache{join("\0", grep { defined } @_)} //= $func->(@args, @_) }; +} + +=func pad_pkcs7 + + $padded_string = pad_pkcs7($string, $block_size), + +Pad a block using the PKCS#7 method. + +=cut + +sub pad_pkcs7 { + my $data = shift // throw 'Must provide a string to pad'; + my $size = shift or throw 'Must provide block size'; + + 0 <= $size && $size < 256 + or throw 'Cannot add PKCS7 padding to a large block size', size => $size; + + my $pad_len = $size - length($data) % $size; + $data .= chr($pad_len) x $pad_len; +} + +=func query + + $query = query(@where); + $query->(\%data); + +Generate a function that will run a series of tests on a passed hashref and return true or false depending on +if the data record in the hash matched the specified logic. + +The logic can be specified in a manner similar to L<SQL::Abstract/"WHERE CLAUSES"> which was the inspiration +for this function, but this code is distinct, supporting an overlapping but not identical feature set and +having its own bugs. + +See L<File::KDBX/QUERY> for examples. + +=cut + +sub query { _query(undef, '-or', \@_) } + +=func read_all + + $size = read_all($fh, my $buffer, $size); + $size = read_all($fh, my $buffer, $size, $offset); + +Like L<functions/read> but returns C<undef> if not all C<$size> bytes are read. This is considered an error, +distinguishable from other errors by C<$!> not being set. + +=cut + +sub read_all($$$;$) { ## no critic (ProhibitSubroutinePrototypes) + my $result = @_ == 3 ? read($_[0], $_[1], $_[2]) + : read($_[0], $_[1], $_[2], $_[3]); + return if !defined $result; + return if $result != $_[2]; + return $result; +} + +=func recurse_limit + + \&limited_code = recurse_limit(\&code); + \&limited_code = recurse_limit(\&code, $max_depth); + \&limited_code = recurse_limit(\&code, $max_depth, \&error_handler); + +Wrap a function with a guard to prevent deep recursion. + +=cut + +sub recurse_limit { + my $func = shift; + my $max_depth = shift // 200; + my $error = shift // sub {}; + my $depth = 0; + return sub { return $error->(@_) if $max_depth < ++$depth; $func->(@_) }; +}; + +=func search + + # Generate a query on-the-fly: + \@matches = search(\@records, @where); + + # Use a pre-compiled query: + $query = query(@where); + \@matches = search(\@records, $query); + + # Use a simple expression: + \@matches = search(\@records, \'query terms', @fields); + \@matches = search(\@records, \'query terms', $operator, @fields); + + # Use your own subroutine: + \@matches = search(\@records, \&query); + \@matches = search(\@records, sub { $record = shift; ... }); + +Execute a linear search over an array of records using a L</query>. A "record" is usually a hash. + +This is the search engine described with many examples at L<File::KDBX/QUERY>. + +=cut + +sub search { + my $list = shift; + my $query = shift; + # my %args = @_; + + if (is_coderef($query) && !@_) { + # already a query + } + elsif (is_scalarref($query)) { + $query = simple_expression_query($$query, @_); + } + else { + $query = query($query, @_); + } + + # my $limit = $args{limit}; + + my @match; + for my $item (@$list) { + push @match, $item if $query->($item); + # last if defined $limit && $limit <= @match; + } + return \@match; +} + +=func simple_expression_query + + $query = simple_expression_query($expression, @fields); + +Generate a query, like L</query>, to be used with L</search> but built from a "simple expression" as +L<described here|https://keepass.info/help/base/search.html#mode_se>. + +An expression is a string with one or more space-separated terms. Terms with spaces can be enclosed in double +quotes. Terms are negated if they are prefixed with a minus sign. A record must match every term on at least +one of the given fields. + +=cut + +sub simple_expression_query { + my $expr = shift; + my $op = @_ && ($OPS{$_[0] || ''} || 0) == 2 ? shift : '=~'; + + my $neg_op = $OP_NEG{$op}; + my $is_re = $op eq '=~' || $op eq '!~'; + + require Text::ParseWords; + my @terms = Text::ParseWords::shellwords($expr); + + my @query = qw(-and); + + for my $term (@terms) { + my @subquery = qw(-or); + + my $neg = $term =~ s/^-//; + my $condition = [($neg ? $neg_op : $op) => ($is_re ? qr/\Q$term\E/i : $term)]; + + for my $field (@_) { + push @subquery, $field => $condition; + } + + push @query, \@subquery; + } + + return query(\@query); +} + +=func snakify + + $string = snakify($string); + +Turn a CamelCase string into snake_case. + +=cut + +sub snakify { + local $_ = shift; + s/UserName/Username/g; + s/([a-z])([A-Z0-9])/${1}_${2}/g; + s/([A-Z0-9]+)([A-Z0-9])(?![A-Z0-9]|$)/${1}_${2}/g; + return lc($_); +} + +=func split_url + + ($scheme, $auth, $host, $port, $path, $query, $hash, $usename, $password) = split_url($url); + +Split a URL into its parts. + +For example, C<http://user:pass@localhost:4000/path?query#hash> gets split like: + +=for :list +* C<http> +* C<user:pass> +* C<host> +* C<4000> +* C</path> +* C<?query> +* C<#hash> +* C<user> +* C<pass> + +=cut + +sub split_url { + local $_ = shift; + my ($scheme, $auth, $host, $port, $path, $query, $hash) =~ m! + ^([^:/\?\#]+) :// + (?:([^\@]+)\@) + ([^:/\?\#]*) + (?::(\d+))? + ([^\?\#]*) + (\?[^\#]*)? + (\#(.*))? + !x; + + $scheme = lc($scheme); + + $host ||= 'localhost'; + $host = lc($host); + + $path = "/$path" if $path !~ m!^/!; + + $port ||= $scheme eq 'http' ? 80 : $scheme eq 'https' ? 433 : undef; + + my ($username, $password) = split($auth, ':', 2); + + return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password); +} + +=func trim + + $string = trim($string); + +The ubiquitous C<trim> function. Removes all whitespace from both ends of a string. + +=cut + +sub trim($) { ## no critic (ProhibitSubroutinePrototypes) + local $_ = shift // return; + s/^\s*//; + s/\s*$//; + return $_; +} + +=func try_load_optional + + $package = try_load_optional($package); + +Try to load a module that isn't required but can provide extra functionality, and return true if successful. + +=cut + +sub try_load_optional { + for my $module (@_) { + eval { load $module }; + if (my $err = $@) { + warn $err if $ENV{DEBUG}; + return; + } + } + return @_; +} + +=func uri_escape_utf8 + + $string = uri_escape_utf8($string); + +Percent-encode arbitrary text strings, like for a URI. + +=cut + +my %ESC = map { chr($_) => sprintf('%%%02X', $_) } 0..255; +sub uri_escape_utf8 { + local $_ = shift // return; + $_ = encode('UTF-8', $_); + # RFC 3986 section 2.3 unreserved characters + s/([^A-Za-z0-9\-\._~])/$ESC{$1}/ge; + return $_; +} + +sub uri_unescape_utf8 { + local $_ = shift // return; + s/\%([A-Fa-f0-9]{2})/chr(hex($1))/; + return decode('UTF-8', $_); +} + +=func uuid + + $raw_uuid = uuid($string_uuid); + +Pack a 128-bit UUID (given as a hexidecimal string with optional C<->'s, like +C<12345678-9ABC-DEFG-1234-56789ABCDEFG>) into a string of exactly 16 octets. + +This is the inverse of L</format_uuid>. + +=cut + +sub uuid { + local $_ = shift // return "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; + s/-//g; + /^[A-Fa-f0-9]{32}$/ or throw 'Must provide a formatted 128-bit UUID'; + return pack('H32', $_); + +} + +BEGIN { + my $use_cowrefcnt = eval { require B::COW; 1 }; + *USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 }; +} + +### -------------------------------------------------------------------------- + +# Determine if an array looks like keypairs from a hash. +sub _looks_like_keypairs { + my $arr = shift; + return 0 if @$arr % 2 == 1; + for (my $i = 0; $i < @$arr; $i += 2) { + return 0 if is_ref($arr->[$i]); + } + return 1; +} + +sub _is_operand_plain { + local $_ = shift; + return !(is_hashref($_) || is_arrayref($_)); +} + +sub _query { + # dumper \@_; + my $subject = shift; + my $op = shift // throw 'Must specify a query operator'; + my $operand = shift; + + return _query_simple($op, $subject) if defined $subject && !is_ref($op) && ($OPS{$subject} || 2) < 2; + return _query_simple($subject, $op, $operand) if _is_operand_plain($operand); + return _query_inverse(_query($subject, '-or', $operand)) if $op eq '-not' || $op eq '-false'; + return _query($subject, '-and', [%$operand]) if is_hashref($operand); + + my @queries; + + my @atoms = @$operand; + while (@atoms) { + if (_looks_like_keypairs(\@atoms)) { + my ($atom, $operand) = splice @atoms, 0, 2; + if (my $op_type = $OPS{$atom}) { + if ($op_type == 1 && _is_operand_plain($operand)) { # unary + push @queries, _query_simple($operand, $atom); + } + else { + push @queries, _query($subject, $atom, $operand); + } + } + elsif (!is_ref($atom)) { + push @queries, _query($atom, 'eq', $operand); + } + } + else { + my $atom = shift @atoms; + if ($OPS{$atom}) { # apply new operator over the rest + push @queries, _query($subject, $atom, \@atoms); + last; + } + else { # apply original operator over this one + push @queries, _query($subject, $op, $atom); + } + } + } + + if (@queries == 1) { + return $queries[0]; + } + elsif ($op eq '-and') { + return _query_all(@queries); + } + elsif ($op eq '-or') { + return _query_any(@queries); + } + throw 'Malformed query'; +} + +sub _query_simple { + my $subject = shift; + my $op = shift // 'eq'; + my $operand = shift; + + # these special operators can also act as simple operators + $op = '!!' if $op eq '-true'; + $op = '!' if $op eq '-false'; + $op = '!' if $op eq '-not'; + + defined $subject or throw 'Subject is not set in query'; + $OPS{$op} >= 0 or throw 'Cannot use a non-simple operator in a simple query'; + if (empty($operand)) { + if ($OPS{$op} < 2) { + # no operand needed + } + # Allow field => undef and field => {'ne' => undef} to do the (arguably) right thing. + elsif ($op eq 'eq' || $op eq '==') { + $op = '-empty'; + } + elsif ($op eq 'ne' || $op eq '!=') { + $op = '-nonempty'; + } + else { + throw 'Operand is required'; + } + } + + my $field = sub { blessed $_[0] && $_[0]->can($subject) ? $_[0]->$subject : $_[0]->{$subject} }; + + my %map = ( + 'eq' => sub { local $_ = $field->(@_); defined && $_ eq $operand }, + 'ne' => sub { local $_ = $field->(@_); defined && $_ ne $operand }, + 'lt' => sub { local $_ = $field->(@_); defined && $_ lt $operand }, + 'gt' => sub { local $_ = $field->(@_); defined && $_ gt $operand }, + 'le' => sub { local $_ = $field->(@_); defined && $_ le $operand }, + 'ge' => sub { local $_ = $field->(@_); defined && $_ ge $operand }, + '==' => sub { local $_ = $field->(@_); defined && $_ == $operand }, + '!=' => sub { local $_ = $field->(@_); defined && $_ != $operand }, + '<' => sub { local $_ = $field->(@_); defined && $_ < $operand }, + '>' => sub { local $_ = $field->(@_); defined && $_ > $operand }, + '<=' => sub { local $_ = $field->(@_); defined && $_ <= $operand }, + '>=' => sub { local $_ = $field->(@_); defined && $_ >= $operand }, + '=~' => sub { local $_ = $field->(@_); defined && $_ =~ $operand }, + '!~' => sub { local $_ = $field->(@_); defined && $_ !~ $operand }, + '!' => sub { local $_ = $field->(@_); ! $_ }, + '!!' => sub { local $_ = $field->(@_); !!$_ }, + '-defined' => sub { local $_ = $field->(@_); defined $_ }, + '-undef' => sub { local $_ = $field->(@_); !defined $_ }, + '-nonempty' => sub { local $_ = $field->(@_); nonempty $_ }, + '-empty' => sub { local $_ = $field->(@_); empty $_ }, + ); + + return $map{$op} // throw "Unexpected operator in query: $op", + subject => $subject, + operator => $op, + operand => $operand; +} + +sub _query_inverse { + my $query = shift; + return sub { !$query->(@_) }; +} + +sub _query_all { + my @queries = @_; + return sub { + my $val = shift; + all { $_->($val) } @queries; + }; +} + +sub _query_any { + my @queries = @_; + return sub { + my $val = shift; + any { $_->($val) } @queries; + }; +} + +1; diff --git a/lib/PerlIO/via/File/KDBX/Compression.pm b/lib/PerlIO/via/File/KDBX/Compression.pm new file mode 100644 index 0000000..a1fd120 --- /dev/null +++ b/lib/PerlIO/via/File/KDBX/Compression.pm @@ -0,0 +1,182 @@ +package PerlIO::via::File::KDBX::Compression; +# ABSTRACT: [De]compressor PerlIO layer + +use warnings; +use strict; + +use Errno; +use File::KDBX::Error; +use File::KDBX::Util qw(load_optional); +use IO::Handle; +use namespace::clean; + +our $VERSION = '999.999'; # VERSION +our $BUFFER_SIZE = 8192; +our $ERROR; + +=method push + + PerlIO::via::File::KDBX::Compression->push($fh); + PerlIO::via::File::KDBX::Compression->push($fh, %options); + +Push a compression or decompression layer onto a filehandle. Data read from the handle is decompressed, and +data written to a handle is compressed. + +Any arguments are passed along to the Inflate or Deflate constructors of C<Compress::Raw::Zlib>. + +This is identical to: + + binmode($fh, ':via(File::KDBX::Compression)'); + +except this allows you to specify compression options. + +B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using +C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data +before the filehandle closes so it can finish the compression correctly, and the way to indicate that is by +popping the layer. + +=cut + +my @PUSHED_ARGS; +sub push { + @PUSHED_ARGS and throw 'Pushing Compression layer would stomp existing arguments'; + my $class = shift; + my $fh = shift; + @PUSHED_ARGS = @_; + binmode($fh, ':via(' . __PACKAGE__ . ')'); +} + +sub PUSHED { + my ($class, $mode) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n"; + my $buf = ''; + + my $self = bless { + buffer => \$buf, + mode => $mode, + $mode =~ /^r/ ? (inflator => _inflator(@PUSHED_ARGS)) : (), + $mode =~ /^w/ ? (deflator => _deflator(@PUSHED_ARGS)) : (), + }, $class; + @PUSHED_ARGS = (); + return $self; +} + +sub FILL { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n"; + return if $self->EOF($fh); + + $fh->read(my $buf, $BUFFER_SIZE); + if (0 < length($buf)) { + my $status = $self->inflator->inflate($buf, my $out); + $status == Compress::Raw::Zlib::Z_OK() || $status == Compress::Raw::Zlib::Z_STREAM_END() or do { + $self->_set_error("Failed to uncompress: $status", status => $status); + return; + }; + return $out; + } + + delete $self->{inflator}; + return undef; +} + +sub WRITE { + my ($self, $buf, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n"; + return 0 if $self->EOF($fh); + + my $status = $self->deflator->deflate($buf, my $out); + $status == Compress::Raw::Zlib::Z_OK() or do { + $self->_set_error("Failed to compress: $status", status => $status); + return 0; + }; + + ${$self->buffer} .= $out; + return length($buf); +} + +sub POPPED { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n"; + return if $self->EOF($fh) || $self->mode !~ /^w/; + + # finish + my $status = $self->deflator->flush(my $out, Compress::Raw::Zlib::Z_FINISH()); + delete $self->{deflator}; + $status == Compress::Raw::Zlib::Z_OK() or do { + $self->_set_error("Failed to compress: $status", status => $status); + return; + }; + + ${$self->buffer} .= $out; + $self->FLUSH($fh); +} + +sub FLUSH { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n"; + return 0 if !ref $self; + + my $buf = $self->buffer; + print $fh $$buf or return -1 if 0 < length($$buf); + $$buf = ''; + return 0; +} + +sub EOF { + $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n"; + (!$_[0]->inflator && !$_[0]->deflator) || $_[0]->ERROR($_[1]); +} +sub ERROR { + $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n"; + $ERROR = $_[0]->{error} if $_[0]->{error}; + $_[0]->{error} ? 1 : 0; +} +sub CLEARERR { + $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n"; + # delete $_[0]->{error}; +} + +sub inflator { $_[0]->{inflator} } +sub deflator { $_[0]->{deflator} } +sub mode { $_[0]->{mode} } +sub buffer { $_[0]->{buffer} } + +sub _inflator { + load_optional('Compress::Raw::Zlib'); + my ($inflator, $status) + = Compress::Raw::Zlib::Inflate->new(-WindowBits => Compress::Raw::Zlib::WANT_GZIP(), @_); + $status == Compress::Raw::Zlib::Z_OK() + or throw 'Failed to initialize inflator', status => $status; + return $inflator; +} + +sub _deflator { + load_optional('Compress::Raw::Zlib'); + my ($deflator, $status) + = Compress::Raw::Zlib::Deflate->new(-WindowBits => Compress::Raw::Zlib::WANT_GZIP(), @_); + $status == Compress::Raw::Zlib::Z_OK() + or throw 'Failed to initialize deflator', status => $status; + return $deflator; +} + +sub _set_error { + my $self = shift; + $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n"; + delete $self->{inflator}; + delete $self->{deflator}; + if (exists &Errno::EPROTO) { + $! = &Errno::EPROTO; + } + elsif (exists &Errno::EIO) { + $! = &Errno::EIO; + } + $self->{error} = $ERROR = File::KDBX::Error->new(@_); +} + +1; diff --git a/lib/PerlIO/via/File/KDBX/Crypt.pm b/lib/PerlIO/via/File/KDBX/Crypt.pm new file mode 100644 index 0000000..4e1231e --- /dev/null +++ b/lib/PerlIO/via/File/KDBX/Crypt.pm @@ -0,0 +1,188 @@ +package PerlIO::via::File::KDBX::Crypt; +# ABSTRACT: Encrypter/decrypter PerlIO layer + +use warnings; +use strict; + +use File::KDBX::Error; +use IO::Handle; +use namespace::clean; + +our $VERSION = '999.999'; # VERSION +our $BUFFER_SIZE = 8192; +our $ERROR; + +=method push + + PerlIO::via::File::KDBX::Crypt->push($fh, cipher => $cipher); + +Push an encryption or decryption layer onto a filehandle. C<$cipher> must be compatible with +L<File::KDBX::Cipher>. + +You mustn't push this layer using C<binmode> directly because the layer needs to be initialized with the +required cipher object. + +B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using +C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data +before the filehandle closes so it can finish the encryption correctly, and the way to indicate that is by +popping the layer. + +=cut + +my %PUSHED_ARGS; +sub push { + %PUSHED_ARGS and throw 'Pushing Crypt layer would stomp existing arguments'; + my $class = shift; + my $fh = shift; + my %args = @_ % 2 == 0 ? @_ : (cipher => @_); + $args{cipher} or throw 'Must pass a cipher'; + $args{cipher}->finish if defined $args{finish} && !$args{finish}; + + %PUSHED_ARGS = %args; + binmode($fh, ':via(' . __PACKAGE__ . ')'); +} + +sub PUSHED { + my ($class, $mode) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n"; + %PUSHED_ARGS or throw 'Programmer error: Use PerlIO::via::File::KDBX::Crypt->push instead of binmode'; + + my $buf = ''; + my $self = bless { + buffer => \$buf, + cipher => $PUSHED_ARGS{cipher}, + mode => $mode, + }, $class; + %PUSHED_ARGS = (); + return $self; +} + +sub FILL { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n"; + return if $self->EOF($fh); + + $fh->read(my $buf, $BUFFER_SIZE); + if (0 < length($buf)) { + my $plaintext = eval { $self->cipher->decrypt($buf) }; + if (my $err = $@) { + $self->_set_error($err); + return; + } + return $plaintext; + } + + # finish + my $plaintext = eval { $self->cipher->finish }; + if (my $err = $@) { + $self->_set_error($err); + return; + } + delete $self->{cipher}; + return $plaintext; +} + +sub WRITE { + my ($self, $buf, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n"; + return 0 if $self->EOF($fh); + + ${$self->buffer} .= eval { $self->cipher->encrypt($buf) } || ''; + if (my $err = $@) { + $self->_set_error($err); + return 0; + } + return length($buf); +} + +sub POPPED { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n"; + return if $self->EOF($fh) || $self->mode !~ /^w/; + + ${$self->buffer} .= eval { $self->cipher->finish } || ''; + if (my $err = $@) { + $self->_set_error($err); + return; + } + + delete $self->{cipher}; + $self->FLUSH($fh); +} + +sub FLUSH { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n"; + return 0 if !ref $self; + + my $buf = $self->buffer; + print $fh $$buf or return -1 if 0 < length($$buf); + $$buf = ''; + return 0; +} + +# sub EOF { !$_[0]->cipher || $_[0]->ERROR($_[1]) } +# sub ERROR { $_[0]->{error} ? 1 : 0 } +# sub CLEARERR { delete $_[0]->{error}; 0 } + +sub EOF { + $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n"; + !$_[0]->cipher || $_[0]->ERROR($_[1]); +} +sub ERROR { + $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n"; + $_[0]->{error} ? 1 : 0; +} +sub CLEARERR { + $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n"; + # delete $_[0]->{error}; +} + +sub cipher { $_[0]->{cipher} } +sub mode { $_[0]->{mode} } +sub buffer { $_[0]->{buffer} } + +sub _set_error { + my $self = shift; + $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n"; + delete $self->{cipher}; + if (exists &Errno::EPROTO) { + $! = &Errno::EPROTO; + } + elsif (exists &Errno::EIO) { + $! = &Errno::EIO; + } + $self->{error} = $ERROR = File::KDBX::Error->new(@_); +} + +1; +__END__ + +=head1 SYNOPSIS + + use PerlIO::via::File::KDBX::Crypt; + use File::KDBX::Cipher; + + my $cipher = File::KDBX::Cipher->new(...); + + open(my $out_fh, '>:raw', 'ciphertext.bin'); + PerlIO::via::File::KDBX::Crypt->push($out_fh, cipher => $cipher); + + print $out_fh $plaintext; + + binmode($out_fh, ':pop'); # <-- This is required. + close($out_fh); + + open(my $in_fh, '<:raw', 'ciphertext.bin'); + PerlIO::via::File::KDBX::Crypt->push($in_fh, cipher => $cipher); + + my $plaintext = do { local $/; <$in_fh> ); + + close($in_fh); + +=cut diff --git a/lib/PerlIO/via/File/KDBX/HashBlock.pm b/lib/PerlIO/via/File/KDBX/HashBlock.pm new file mode 100644 index 0000000..ce1b935 --- /dev/null +++ b/lib/PerlIO/via/File/KDBX/HashBlock.pm @@ -0,0 +1,281 @@ +package PerlIO::via::File::KDBX::HashBlock; +# ABSTRACT: Hash block stream PerlIO layer + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use File::KDBX::Error; +use File::KDBX::Util qw(:io); +use IO::Handle; +use namespace::clean; + +our $VERSION = '999.999'; # VERSION +our $ALGORITHM = 'SHA256'; +our $BLOCK_SIZE = 1048576; +our $ERROR; + +=method push + + PerlIO::via::File::KDBX::HashBlock->push($fh, %attributes); + +Push a new HashBlock layer, optionally with attributes. + +This is identical to: + + binmode($fh, ':via(File::KDBX::HashBlock)'); + +except this allows you to customize the process with attributes. + +B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using +C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data +before the filehandle closes so it can write the final block (which will likely be shorter than the other +blocks), and the way to indicate that is by popping the layer. + +=cut + +my %PUSHED_ARGS; +sub push { + %PUSHED_ARGS and throw 'Pushing Hash layer would stomp existing arguments'; + my $class = shift; + my $fh = shift; + %PUSHED_ARGS = @_; + binmode($fh, ':via(' . __PACKAGE__ . ')'); +} + +sub PUSHED { + my ($class, $mode) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n"; + my $buf = ''; + my $self = bless { + algorithm => $PUSHED_ARGS{algorithm} || $ALGORITHM, + block_index => 0, + block_size => $PUSHED_ARGS{block_size} || $BLOCK_SIZE, + buffer => \$buf, + eof => 0, + mode => $mode, + }, $class; + %PUSHED_ARGS = (); + return $self; +} + +sub FILL { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n"; + return if $self->EOF($fh); + + my $block = eval { $self->_read_hash_block($fh) }; + if (my $err = $@) { + $self->_set_error($err); + return; + } + return $$block if defined $block; +} + +sub WRITE { + my ($self, $buf, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n"; + return 0 if $self->EOF($fh); + + ${$self->{buffer}} .= $buf; + + $self->FLUSH($fh); + + return length($buf); +} + +sub POPPED { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n"; + return if $self->EOF($fh) || $self->mode !~ /^w/; + + $self->FLUSH($fh); + eval { + $self->_write_next_hash_block($fh); # partial block with remaining content + $self->_write_final_hash_block($fh); # terminating block + }; + $self->_set_error($@) if $@; +} + +sub FLUSH { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n"; + return 0 if !ref $self; + + eval { + while ($self->block_size <= length(${$self->{buffer}})) { + $self->_write_next_hash_block($fh); + } + }; + if (my $err = $@) { + $self->_set_error($err); + return -1; + } + + return 0; +} + +sub EOF { + $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n"; + $_[0]->{eof} || $_[0]->ERROR($_[1]); +} +sub ERROR { + $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n"; + $ERROR = $_[0]->{error} if $_[0]->{error}; + $_[0]->{error} ? 1 : 0; +} +sub CLEARERR { + $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n"; + # delete $_[0]->{error}; +} + +=attr algorithm + + $algo = $hash_block->algorithm; + +Get the hash algorithm. Default is C<SHA256>. + +=cut + +sub algorithm { $_[0]->{algorithm} //= $ALGORITHM } + +=attr block_size + + $size = $hash_block->block_size; + +Get the block size. Default is C<$PerlIO::via::File::KDBX::HashBlock::BLOCK_SIZE>. + +This only matters in write mode. When reading, block size is detected from the stream. + +=cut + +sub block_size { $_[0]->{block_size} //= $BLOCK_SIZE } + +=attr block_index + +=attr buffer + +=attr mode + +Internal attributes. + +=cut + +sub block_index { $_[0]->{block_index} ||= 0 } +sub buffer { $_[0]->{buffer} } +sub mode { $_[0]->{mode} } + +sub _read_hash_block { + my $self = shift; + my $fh = shift; + + read_all $fh, my $buf, 4 or throw 'Failed to read hash block index'; + my ($index) = unpack('L<', $buf); + + $index == $self->block_index + or throw 'Invalid block index', index => $index; + + read_all $fh, my $hash, 32 or throw 'Failed to read hash'; + + read_all $fh, $buf, 4 or throw 'Failed to read hash block size'; + my ($size) = unpack('L<', $buf); + + if ($size == 0) { + $hash eq ("\0" x 32) + or throw 'Invalid final block hash', hash => $hash; + $self->{eof} = 1; + return undef; + } + + read_all $fh, my $block, $size or throw 'Failed to read hash block', index => $index, size => $size; + + my $got_hash = digest_data('SHA256', $block); + $hash eq $got_hash + or throw 'Hash mismatch', index => $index, size => $size, got => $got_hash, expected => $hash; + + $self->{block_index}++; + return \$block; +} + +sub _write_next_hash_block { + my $self = shift; + my $fh = shift; + + my $size = length(${$self->buffer}); + $size = $self->block_size if $self->block_size < $size; + return 0 if $size == 0; + + my $block = substr(${$self->buffer}, 0, $size, ''); + + my $buf = pack('L<', $self->block_index); + print $fh $buf or throw 'Failed to write hash block index'; + + my $hash = digest_data('SHA256', $block); + print $fh $hash or throw 'Failed to write hash'; + + $buf = pack('L<', length($block)); + print $fh $buf or throw 'Failed to write hash block size'; + + # $fh->write($block, $size) or throw 'Failed to hash write block'; + print $fh $block or throw 'Failed to hash write block'; + + $self->{block_index}++; + return 0; +} + +sub _write_final_hash_block { + my $self = shift; + my $fh = shift; + + my $buf = pack('L<', $self->block_index); + print $fh $buf or throw 'Failed to write hash block index'; + + my $hash = "\0" x 32; + print $fh $hash or throw 'Failed to write hash'; + + $buf = pack('L<', 0); + print $fh $buf or throw 'Failed to write hash block size'; + + $self->{eof} = 1; + return 0; +} + +sub _set_error { + my $self = shift; + $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n"; + if (exists &Errno::EPROTO) { + $! = &Errno::EPROTO; + } + elsif (exists &Errno::EIO) { + $! = &Errno::EIO; + } + $self->{error} = $ERROR = File::KDBX::Error->new(@_); +} + +1; +__END__ + +=head1 DESCRIPTION + +Writing to a handle with this layer will transform the data in a series of blocks. Each block is hashed, and +the hash is included with the block in the stream. + +Reading from a handle, each hash block will be verified as the blocks are disassembled back into a data +stream. + +Each block is encoded thusly: + +=for :list +* Block index - Little-endian unsigned 32-bit integer, increments starting with 0 +* Hash - 32 bytes +* Block size - Little-endian unsigned 32-bit (counting only the data) +* Data - String of bytes + +The terminating block is an empty block where hash is 32 null bytes, block size is 0 and there is no data. + +=cut diff --git a/lib/PerlIO/via/File/KDBX/HmacBlock.pm b/lib/PerlIO/via/File/KDBX/HmacBlock.pm new file mode 100644 index 0000000..ba54d60 --- /dev/null +++ b/lib/PerlIO/via/File/KDBX/HmacBlock.pm @@ -0,0 +1,291 @@ +package PerlIO::via::File::KDBX::HmacBlock; +# ABSTRACT: HMAC block-stream PerlIO layer + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Crypt::Mac::HMAC qw(hmac); +use File::KDBX::Error; +use File::KDBX::Util qw(:io assert_64bit); +use namespace::clean; + +our $VERSION = '999.999'; # VERSION +our $BLOCK_SIZE = 1048576; +our $ERROR; + +=method push + + PerlIO::via::File::KDBX::HmacBlock->push($fh, key => $key); + PerlIO::via::File::KDBX::HmacBlock->push($fh, key => $key, block_size => $size); + +Push a new HMAC-block layer with arguments. A key is required. + +B<WARNING:> You mustn't push this layer using C<binmode> directly because the layer needs to be initialized +with the key and any other desired attributes. + +B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using +C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data +before the filehandle closes so it can write the final block (which will likely be shorter than the other +blocks), and the way to indicate that is by popping the layer. + +=cut + +my %PUSHED_ARGS; +sub push { + assert_64bit; + + %PUSHED_ARGS and throw 'Pushing HmacBlock layer would stomp existing arguments'; + + my $class = shift; + my $fh = shift; + my %args = @_ % 2 == 0 ? @_ : (key => @_); + $args{key} or throw 'Must pass a key'; + + my $key_size = length($args{key}); + $key_size == 64 or throw 'Key must be 64 bytes in length', size => $key_size; + + %PUSHED_ARGS = %args; + binmode($fh, ':via(' . __PACKAGE__ . ')'); +} + +sub PUSHED { + my ($class, $mode) = @_; + + %PUSHED_ARGS or throw 'Programmer error: Use PerlIO::via::File::KDBX::HmacBlock->push instead of binmode'; + + $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n"; + my $buf = ''; + my $self = bless { + block_index => 0, + block_size => $PUSHED_ARGS{block_size} || $BLOCK_SIZE, + buffer => \$buf, + key => $PUSHED_ARGS{key}, + mode => $mode, + }, $class; + %PUSHED_ARGS = (); + return $self; +} + +sub FILL { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n"; + return if $self->EOF($fh); + + my $block = eval { $self->_read_hashed_block($fh) }; + if (my $err = $@) { + $self->_set_error($err); + return; + } + if (length($block) == 0) { + $self->{eof} = 1; + return; + } + return $block; +} + +sub WRITE { + my ($self, $buf, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n"; + return 0 if $self->EOF($fh); + + ${$self->{buffer}} .= $buf; + + $self->FLUSH($fh); + + return length($buf); +} + +sub POPPED { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n"; + return if $self->mode !~ /^w/; + + $self->FLUSH($fh); + eval { + $self->_write_next_hmac_block($fh); # partial block with remaining content + $self->_write_final_hmac_block($fh); # terminating block + }; + $self->_set_error($@) if $@; +} + +sub FLUSH { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n"; + return 0 if !ref $self; + + eval { + while ($self->block_size <= length(${$self->{buffer}})) { + $self->_write_next_hmac_block($fh); + } + }; + if (my $err = $@) { + $self->_set_error($err); + return -1; + } + + return 0; +} + +sub EOF { + $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n"; + $_[0]->{eof} || $_[0]->ERROR($_[1]); +} +sub ERROR { + $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n"; + $ERROR = $_[0]->{error} if $_[0]->{error}; + $_[0]->{error} ? 1 : 0; +} +sub CLEARERR { + $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n"; + # delete $_[0]->{error}; +} + +=attr key + + $key = $hmac_block->key; + +Get the key used for authentication. The key must be exactly 64 bytes in size. + +=cut + +sub key { $_[0]->{key} or throw 'Key is not set' } + +=attr block_size + + $size = $hmac_block->block_size; + +Get the block size. Default is C<$PerlIO::via::File::KDBX::HmacBlock::BLOCK_SIZE>. + +This only matters in write mode. When reading, block size is detected from the stream. + +=cut + +sub block_size { $_[0]->{block_size} ||= $BLOCK_SIZE } + +=attr block_index + +=attr buffer + +=attr mode + +Internal attributes. + +=cut + +sub block_index { $_[0]->{block_index} ||= 0 } +sub buffer { $_[0]->{buffer} } +sub mode { $_[0]->{mode} } + +sub _read_hashed_block { + my $self = shift; + my $fh = shift; + + read_all $fh, my $hmac, 32 or throw 'Failed to read HMAC'; + + read_all $fh, my $size_buf, 4 or throw 'Failed to read HMAC block size'; + my ($size) = unpack('L<', $size_buf); + + my $block = ''; + if (0 < $size) { + read_all $fh, $block, $size + or throw 'Failed to read HMAC block', index => $self->block_index, size => $size; + } + + my $index_buf = pack('Q<', $self->block_index); + my $got_hmac = hmac('SHA256', $self->_hmac_key, + $index_buf, + $size_buf, + $block, + ); + + $hmac eq $got_hmac + or throw 'Block authentication failed', index => $self->block_index, got => $got_hmac, expected => $hmac; + + $self->{block_index}++; + + return $block; +} + +sub _write_next_hmac_block { + my $self = shift; + my $fh = shift; + my $buffer = shift // $self->buffer; + my $allow_empty = shift; + + my $size = length($$buffer); + $size = $self->block_size if $self->block_size < $size; + return 0 if $size == 0 && !$allow_empty; + + my $block = ''; + $block = substr($$buffer, 0, $size, '') if 0 < $size; + + my $index_buf = pack('Q<', $self->block_index); + my $size_buf = pack('L<', $size); + my $hmac = hmac('SHA256', $self->_hmac_key, + $index_buf, + $size_buf, + $block, + ); + + print $fh $hmac, $size_buf, $block + or throw 'Failed to write HMAC block', hmac => $hmac, block_size => $size, err => $fh->error; + + $self->{block_index}++; + return 0; +} + +sub _write_final_hmac_block { + my $self = shift; + my $fh = shift; + + $self->_write_next_hmac_block($fh, \'', 1); +} + +sub _hmac_key { + my $self = shift; + my $key = shift // $self->key; + my $index = shift // $self->block_index; + + my $index_buf = pack('Q<', $index); + my $hmac_key = digest_data('SHA512', $index_buf, $key); + return $hmac_key; +} + +sub _set_error { + my $self = shift; + $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n"; + if (exists &Errno::EPROTO) { + $! = &Errno::EPROTO; + } + elsif (exists &Errno::EIO) { + $! = &Errno::EIO; + } + $self->{error} = $ERROR = File::KDBX::Error->new(@_); +} + +1; +__END__ + +=head1 DESCRIPTION + +Writing to a handle with this layer will transform the data in a series of blocks. An HMAC is calculated for +each block and is included in the output. + +Reading from a handle, each block will be verified and authenticated as the blocks are disassembled back into +a data stream. + +Each block is encoded thusly: + +=for :list +* HMAC - 32 bytes, calculated over [block index (increments starting with 0), block size and data] +* Block size - Little-endian unsigned 32-bit (counting only the data) +* Data - String of bytes + +The terminating block is an empty block encoded as usual but block size is 0 and there is no data. + +=cut diff --git a/t/compression.t b/t/compression.t new file mode 100644 index 0000000..3412dc2 --- /dev/null +++ b/t/compression.t @@ -0,0 +1,45 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use IO::Handle; +use PerlIO::via::File::KDBX::Compression; +use Test::More; + +eval { require Compress::Raw::Zlib } + or plan skip_all => 'Compress::Zlib::Raw required to test compression'; + +my $expected_plaintext = 'Tiny food from Spain!'; + +pipe(my $read, my $write) or die "pipe failed: $!"; +PerlIO::via::File::KDBX::Compression->push($read); +PerlIO::via::File::KDBX::Compression->push($write); + +print $write $expected_plaintext or die "print failed: $!"; +binmode($write, ':pop'); # finish stream +close($write) or die "close failed: $!"; + +my $plaintext = do { local $/; <$read> }; +close($read); +is $plaintext, $expected_plaintext, 'Deflate and inflate a string'; + +{ + pipe(my $read, my $write) or die "pipe failed: $!"; + PerlIO::via::File::KDBX::Compression->push($read); + + print $write 'blah blah blah' or die "print failed: $!"; + close($write) or die "close failed: $!"; + + is $read->error, 0, 'Read handle starts out fine'; + my $plaintext = do { local $/; <$read> }; + is $read->error, 1, 'Read handle can enter and error state'; + + like $PerlIO::via::File::KDBX::Compression::ERROR, qr/failed to uncompress/i, + 'Error object is available'; +} + +done_testing; diff --git a/t/crypt.t b/t/crypt.t new file mode 100644 index 0000000..576f708 --- /dev/null +++ b/t/crypt.t @@ -0,0 +1,83 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use Crypt::Misc 0.029 qw(decode_b64 encode_b64); +use File::KDBX::Constants qw(CIPHER_UUID_AES256); +use IO::Handle; +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); + test_roundtrip($block_cipher, + 'Smell the pretty flowers.', + decode_b64('pB10mV+mhTuh7bKg0KEUl5H1ajFMaP4uPnTZNcDgq6s='), + ); +}; + +subtest 'Round-trip cipher stream' => sub { + plan tests => 3; + my $cipher_stream = File::KDBX::Cipher->new(stream_id => 2, key => 0x01 x 16); + test_roundtrip($cipher_stream, + 'Smell the pretty flowers.', + decode_b64('gNj2Ud9tWtFDy+xDN/U01RxmCoI6MAlTKQ=='), + ); +}; + +subtest 'Error handling' => sub { + plan tests => 3; + + my $block_cipher = File::KDBX::Cipher->new(uuid => CIPHER_UUID_AES256, key => 0x01 x 32, iv => 0x01 x 16); + pipe(my $read, my $write) or die "pipe failed: $!"; + PerlIO::via::File::KDBX::Crypt->push($read, $block_cipher); + + print $write 'blah blah blah!!'; + close($write) or die "close failed: $!"; + + is $read->error, 0, 'Read handle starts out fine'; + my $plaintext = do { local $/; <$read> }; + is $read->error, 1, 'Read handle can enter and error state'; + + like $PerlIO::via::File::KDBX::Crypt::ERROR, qr/fatal/i, + 'Error object is available'; +}; + +done_testing; +exit; + +sub test_roundtrip { + my $cipher = shift; + my $expected_plaintext = shift; + my $expected_ciphertext = shift; + + pipe(my $read, my $write) or die "pipe failed: $!"; + PerlIO::via::File::KDBX::Crypt->push($write, $cipher); + + print $write $expected_plaintext; + binmode($write, ':pop'); # finish stream + close($write) or die "close failed: $!"; + + my $ciphertext = do { local $/; <$read> }; + close($read); + is $ciphertext, $expected_ciphertext, 'Encrypted a string' + or diag encode_b64($ciphertext); + + my $ciphertext2 = $cipher->encrypt_finish($expected_plaintext); + is $ciphertext, $ciphertext2, 'Same result'; + + open(my $fh, '<', \$ciphertext) or die "open failed: $!\n"; + PerlIO::via::File::KDBX::Crypt->push($fh, $cipher); + + my $plaintext = do { local $/; <$fh> }; + close($fh); + is $plaintext, $expected_plaintext, 'Decrypted a string' + or diag encode_b64($plaintext); +} diff --git a/t/database.t b/t/database.t new file mode 100644 index 0000000..951ff74 --- /dev/null +++ b/t/database.t @@ -0,0 +1,35 @@ +#!/usr/bin/env perl + +use utf8; +use warnings; +use strict; + +use FindBin qw($Bin); +use lib "$Bin/lib"; +use TestCommon; + +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'; + + $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; + + # dumper $kdbx->groups; + + pass; +}; + +done_testing; diff --git a/t/entry.t b/t/entry.t new file mode 100644 index 0000000..a4286cf --- /dev/null +++ b/t/entry.t @@ -0,0 +1,99 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +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'; + isa_ok $data, 'File::KDBX::Entry', 'Data structure is blessed'; + is $entry->{username}, 'foo', 'username is in the object still'; + is $entry->username, '', 'username is not the UserName string'; + + like exception { $entry->kdbx }, qr/disassociated from a KDBX database/, 'Dies if disassociated'; + $entry->kdbx(my $kdbx = File::KDBX->new); + is $entry->kdbx, $kdbx, 'Set a database after instantiation'; + + is_deeply $entry, {username => 'foo', strings => {UserName => {value => ''}}}, + 'Entry data contains what was provided to the constructor plus vivified username'; + + $entry = File::KDBX::Entry->new(username => 'bar'); + is $entry->{username}, undef, 'username is not set on the data'; + is $entry->username, 'bar', 'username is set correctly as the UserName string'; + + cmp_deeply $entry, noclass({ + auto_type => {}, + background_color => "", + binaries => {}, + custom_data => {}, + custom_icon_uuid => undef, + foreground_color => "", + icon_id => "Password", + override_url => "", + previous_parent_group => undef, + quality_check => bool(1), + strings => { + Notes => { + value => "", + }, + Password => { + protect => bool(1), + value => "", + }, + Title => { + value => "", + }, + URL => { + value => "", + }, + UserName => { + value => "bar", + }, + }, + tags => "", + times => { + last_modification_time => isa('Time::Piece'), + creation_time => isa('Time::Piece'), + last_access_time => isa('Time::Piece'), + expiry_time => isa('Time::Piece'), + expires => bool(0), + usage_count => 0, + location_changed => isa('Time::Piece'), + }, + uuid => re('^(?s:.){16}$'), + }), 'Entry data contains UserName string and the rest default attributes'; +}; + +subtest 'Custom icons' => sub { + plan tests => 10; + my $gif = pack('H*', '4749463839610100010000ff002c00000000010001000002003b'); + + my $entry = File::KDBX::Entry->new(my $kdbx = File::KDBX->new, icon_id => 42); + is $entry->custom_icon_uuid, undef, 'UUID is undef if no custom icon is set'; + is $entry->custom_icon, undef, 'Icon is undef if no custom icon is set'; + is $entry->icon_id, 42, 'Default icon is set to something'; + + is $entry->custom_icon($gif), $gif, 'Setting a custom icon returns icon'; + is $entry->custom_icon, $gif, 'Henceforth the icon is set'; + is $entry->icon_id, 0, 'Default icon got changed to first icon'; + my $uuid = $entry->custom_icon_uuid; + isnt $uuid, undef, 'UUID is now set'; + + my $found = $entry->kdbx->custom_icon_data($uuid); + is $entry->custom_icon, $found, 'Custom icon on entry matches the database'; + + is $entry->custom_icon(undef), undef, 'Unsetting a custom icon returns undefined'; + $found = $entry->kdbx->custom_icon_data($uuid); + is $found, $gif, 'Custom icon still exists in the database'; +}; + +done_testing; diff --git a/t/erase.t b/t/erase.t new file mode 100644 index 0000000..3730fcd --- /dev/null +++ b/t/erase.t @@ -0,0 +1,47 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Util qw(erase erase_scoped); +use Test::More; + +my $data1 = 'hello'; +my $data2 = 'hello'; +my $hash1 = {foo => 'secret'}; +my $array1 = [qw(bar baz)]; + +erase $data1, \$data2, $hash1, $array1; +is $data1, undef, 'Erase by alias'; +is $data2, undef, 'Erase by reference'; +is scalar keys %$hash1, 0, 'Erase by hashref'; +is scalar @$array1, 0, 'Erase by arrayref'; + +{ + my $data3 = 'hello'; + my $cleanup = erase_scoped $data3; + is $data3, 'hello', 'Data not yet erased'; + undef $cleanup; + is $data3, undef, 'Scoped erased'; +} + +sub get_secret { + my $secret = 'conspiracy'; + my $cleanup = erase_scoped \$secret; + return $secret; +} + +my $another; +{ + my $thing = get_secret(); + $another = $thing; + is $thing, 'conspiracy', 'Data not yet erased'; + undef $thing; + is $thing, undef, 'Scope erased'; +} +is $another, 'conspiracy', 'Data not erased in the other scalar'; + +done_testing; diff --git a/t/error.t b/t/error.t new file mode 100644 index 0000000..ae467f2 --- /dev/null +++ b/t/error.t @@ -0,0 +1,115 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX; +use Test::More; + +BEGIN { use_ok 'File::KDBX::Error' } + +subtest 'Errors' => sub { + my $error = exception { + local $! = 1; + $@ = 'last exception'; + throw 'uh oh', foo => 'bar'; + }; + like $error, qr/uh oh/, 'Errors can be thrown using the "throw" function'; + + $error = exception { $error->throw }; + like $error, qr/uh oh/, 'Errors can be rethrown'; + + is $error->details->{foo}, 'bar', 'Errors can have details'; + is $error->errno+0, 1, 'Errors record copy of errno when thrown'; + is $error->previous, 'last exception', 'Warnings record copy of the last exception'; + + my $trace = $error->trace; + ok 0 < @$trace, 'Errors record a stacktrace'; + like $trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; + + { + local $ENV{DEBUG} = ''; + like "$error", qr!^uh oh at \H+error\.t line \d+\.$!, 'Errors stringify without stacktrace'; + } + + { + local $ENV{DEBUG} = '1'; + like "$error", qr!^uh oh at \H+error\.t line \d+\.\nbless!, + 'Errors stringify with stacktrace when DEBUG environment variable is set'; + } + + $error = exception { File::KDBX::Error->throw('uh oh') }; + like $error, qr/uh oh/, 'Errors can be thrown using the "throw" constructor'; + like $error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; + + $error = File::KDBX::Error->new('uh oh'); + $error = exception { $error->throw }; + like $error, qr/uh oh/, 'Errors can be thrown using the "throw" method'; + like $error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; +}; + +subtest 'Warnings' => sub { + my $warning = warning { + local $! = 1; + $@ = 'last exception'; + alert 'uh oh', foo => 'bar'; + }; + like $warning, qr/uh oh/, 'Warnings are enabled by default' or diag 'Warnings: ', explain $warning; + + SKIP: { + skip 'Warning object requires Perl 5.14 or later' if $] < 5.014; + is $warning->details->{foo}, 'bar', 'Warnings can have details'; + is $warning->errno+0, 1, 'Warnings record copy of errno when logged'; + is $warning->previous, 'last exception', 'Warnings record copy of the last exception'; + like $warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; + }; + + $warning = warning { File::KDBX::Error->warn('uh oh') }; + like $warning, qr/uh oh/, 'Warnings can be logged using the "alert" constructor'; + SKIP: { + skip 'Warning object requires Perl 5.14 or later' if $] < 5.014; + like $warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; + }; + + my $error = File::KDBX::Error->new('uh oh'); + $warning = warning { $error->alert }; + like $warning, qr/uh oh/, 'Warnings can be logged using the "alert" method'; + SKIP: { + skip 'Warning object requires Perl 5.14 or later' if $] < 5.014; + like $warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; + }; + + { + local $File::KDBX::WARNINGS = 0; + my @warnings = warnings { alert 'uh oh' }; + is @warnings, 0, 'Warnings can be disabled locally' + or diag 'Warnings: ', explain(\@warnings); + } + + SKIP: { + skip 'warnings::warnif_at_level is required', 1 if !warnings->can('warnif_at_level'); + no warnings 'File::KDBX'; + my @warnings = warnings { alert 'uh oh' }; + is @warnings, 0, 'Warnings can be disabled lexically' + or diag 'Warnings: ', explain(\@warnings); + } + + SKIP: { + skip 'warnings::fatal_enabled_at_level is required', 1 if !warnings->can('fatal_enabled_at_level'); + use warnings FATAL => 'File::KDBX'; + my $exception = exception { alert 'uh oh' }; + like $exception, qr/uh oh/, 'Warnings can be fatal'; + } + + { + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + alert 'uh oh'; + like $warning, qr/uh oh/, 'Warnings can be caught'; + } +}; + +done_testing; diff --git a/t/files/BrokenHeaderHash.kdbx b/t/files/BrokenHeaderHash.kdbx new file mode 100644 index 0000000..6c4c439 Binary files /dev/null and b/t/files/BrokenHeaderHash.kdbx differ diff --git a/t/files/CP-1252.kdb b/t/files/CP-1252.kdb new file mode 100644 index 0000000..707bc45 Binary files /dev/null and b/t/files/CP-1252.kdb differ diff --git a/t/files/CompositeKey.kdb b/t/files/CompositeKey.kdb new file mode 100644 index 0000000..70060d8 Binary files /dev/null and b/t/files/CompositeKey.kdb differ diff --git a/t/files/Compressed.kdbx b/t/files/Compressed.kdbx new file mode 100644 index 0000000..1f8ec2d Binary files /dev/null and b/t/files/Compressed.kdbx differ diff --git a/t/files/FileKeyBinary.kdb b/t/files/FileKeyBinary.kdb new file mode 100644 index 0000000..0ce9f58 Binary files /dev/null and b/t/files/FileKeyBinary.kdb differ diff --git a/t/files/FileKeyBinary.kdbx b/t/files/FileKeyBinary.kdbx new file mode 100644 index 0000000..fb9493f Binary files /dev/null and b/t/files/FileKeyBinary.kdbx differ diff --git a/t/files/FileKeyBinary.key b/t/files/FileKeyBinary.key new file mode 100644 index 0000000..bc9591b --- /dev/null +++ b/t/files/FileKeyBinary.key @@ -0,0 +1 @@ +  !"#$%&'()012 \ No newline at end of file diff --git a/t/files/FileKeyHashed.kdb b/t/files/FileKeyHashed.kdb new file mode 100644 index 0000000..8ef7347 Binary files /dev/null and b/t/files/FileKeyHashed.kdb differ diff --git a/t/files/FileKeyHashed.kdbx b/t/files/FileKeyHashed.kdbx new file mode 100644 index 0000000..dd60ddc Binary files /dev/null and b/t/files/FileKeyHashed.kdbx differ diff --git a/t/files/FileKeyHashed.key b/t/files/FileKeyHashed.key new file mode 100644 index 0000000..33f4a9f Binary files /dev/null and b/t/files/FileKeyHashed.key differ diff --git a/t/files/FileKeyHex.kdb b/t/files/FileKeyHex.kdb new file mode 100644 index 0000000..ed872c5 Binary files /dev/null and b/t/files/FileKeyHex.kdb differ diff --git a/t/files/FileKeyHex.kdbx b/t/files/FileKeyHex.kdbx new file mode 100644 index 0000000..33f1fb1 Binary files /dev/null and b/t/files/FileKeyHex.kdbx differ diff --git a/t/files/FileKeyHex.key b/t/files/FileKeyHex.key new file mode 100644 index 0000000..1bf8e5d --- /dev/null +++ b/t/files/FileKeyHex.key @@ -0,0 +1 @@ +0123456789abcdeffedcba98765432100123456789abcdeffedcba9876543210 \ No newline at end of file diff --git a/t/files/Format200.kdbx b/t/files/Format200.kdbx new file mode 100644 index 0000000..c3b26cd Binary files /dev/null and b/t/files/Format200.kdbx differ diff --git a/t/files/Format300.kdbx b/t/files/Format300.kdbx new file mode 100644 index 0000000..dc67f35 Binary files /dev/null and b/t/files/Format300.kdbx differ diff --git a/t/files/Format400.kdbx b/t/files/Format400.kdbx new file mode 100644 index 0000000..1a87750 Binary files /dev/null and b/t/files/Format400.kdbx differ diff --git a/t/files/MemoryProtection.kdbx b/t/files/MemoryProtection.kdbx new file mode 100644 index 0000000..6510cea Binary files /dev/null and b/t/files/MemoryProtection.kdbx differ diff --git a/t/files/NonAscii.kdbx b/t/files/NonAscii.kdbx new file mode 100644 index 0000000..06aa5bf Binary files /dev/null and b/t/files/NonAscii.kdbx differ diff --git a/t/files/ProtectedStrings.kdbx b/t/files/ProtectedStrings.kdbx new file mode 100644 index 0000000..bb50c03 Binary files /dev/null and b/t/files/ProtectedStrings.kdbx differ diff --git a/t/files/Twofish.kdb b/t/files/Twofish.kdb new file mode 100644 index 0000000..eb4ae6d Binary files /dev/null and b/t/files/Twofish.kdb differ diff --git a/t/files/basic.kdb b/t/files/basic.kdb new file mode 100644 index 0000000..16968ba Binary files /dev/null and b/t/files/basic.kdb differ diff --git a/t/files/bin/ykchalresp b/t/files/bin/ykchalresp new file mode 100755 index 0000000..7cac1f5 --- /dev/null +++ b/t/files/bin/ykchalresp @@ -0,0 +1,76 @@ +#!/bin/sh + +# This is a fake ykchalresp program that provides canned responses, for testing. + +device= +slot= +blocking=1 +hmac= +in= + +while getopts 12HNn:i: arg +do + case "$arg" in + n) + device="$OPTARG" + ;; + 1) + slot=1 + ;; + 2) + slot=2 + ;; + H) + hmac=1 + ;; + N) + blocking=0 + ;; + i) + in="$OPTARG" + ;; + esac +done + +if [ -z "$hmac" ] +then + echo 'HMAC-SHA1 not requested' >&2 + exit 3 +fi + +if [ "$in" != '-' ] +then + echo "Unexpected input file: $in" >&2 + exit 3 +fi + +read challenge + +succeed() { + echo "${YKCHALRESP_RESPONSE:-f000000000000000000000000000000000000000}" + exit 0 +} + +case "$YKCHALRESP_MOCK" in + block) + if [ "$blocking" -eq 0 ] + then + echo "Yubikey core error: operation would block" >&2 + exit 1 + fi + sleep 2 + succeed + ;; + error) + echo "Yubikey core error: ${YKCHALRESP_ERROR:-not yet implemented}" >&2 + exit 1 + ;; + usberror) + echo "USB error: something happened" >&2 + exit 1 + ;; + *) # OK + succeed + ;; +esac +exit 2 diff --git a/t/files/bin/ykinfo b/t/files/bin/ykinfo new file mode 100755 index 0000000..8a93cc3 --- /dev/null +++ b/t/files/bin/ykinfo @@ -0,0 +1,43 @@ +#!/bin/sh + +# This is a fake ykinfo program that provides canned responses, for testing. + +device= +all= + +while getopts an: arg +do + case "$arg" in + n) + device="$OPTARG" + ;; + a) + all=1 + ;; + esac +done + +case "$device" in + 0) + printf 'serial: 123 +version: 2.0.0 +touch_level: 0 +vendor_id: 1050 +product_id: 113 +' + exit 0 + ;; + 1) + printf 'serial: 456 +version: 3.0.1 +touch_level: 10 +vendor_id: 1050 +product_id: 401 +' + exit 0 + ;; + *) + echo "Yubikey core error: no yubikey present" >&2 + exit 1 +esac + diff --git a/t/files/keys/binary.key b/t/files/keys/binary.key new file mode 100644 index 0000000..e07f501 --- /dev/null +++ b/t/files/keys/binary.key @@ -0,0 +1 @@ +BYÆæ ðé wJ׎ôA/à } ¼ð=—dI \ No newline at end of file diff --git a/t/files/keys/hashed.key b/t/files/keys/hashed.key new file mode 100644 index 0000000..2f28ba4 --- /dev/null +++ b/t/files/keys/hashed.key @@ -0,0 +1 @@ +We are all Satoshi. diff --git a/t/files/keys/hex.key b/t/files/keys/hex.key new file mode 100644 index 0000000..7bf7fbc --- /dev/null +++ b/t/files/keys/hex.key @@ -0,0 +1 @@ +425903c6e61b0cf0e90d774ad78ef41305412fe009047da0bcf03d9713641449 \ No newline at end of file diff --git a/t/files/keys/xmlv1.key b/t/files/keys/xmlv1.key new file mode 100644 index 0000000..856e510 --- /dev/null +++ b/t/files/keys/xmlv1.key @@ -0,0 +1,11 @@ +<?xml version="1.0" encoding="UTF-8"?> +<KeyFile> + <Meta> + <Version>1.0</Version> + </Meta> + <Key> + <Data> + OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI= + </Data> + </Key> +</KeyFile> diff --git a/t/files/keys/xmlv2.key b/t/files/keys/xmlv2.key new file mode 100644 index 0000000..cb49062 --- /dev/null +++ b/t/files/keys/xmlv2.key @@ -0,0 +1,12 @@ +<?xml version="1.0" encoding="UTF-8"?> +<KeyFile> + <Meta> + <Version>2.0</Version> + </Meta> + <Key> + <Data Hash="984A141E"> + 385F6D8F EB5FC30D 641CD590 68995958 + 89417684 D55CE6B3 3FC83FBD 92BB35C2 + </Data> + </Key> +</KeyFile> diff --git a/t/hash-block.t b/t/hash-block.t new file mode 100644 index 0000000..006f617 --- /dev/null +++ b/t/hash-block.t @@ -0,0 +1,73 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon qw(:no_warnings_test); + +use File::KDBX::Util qw(can_fork); +use IO::Handle; +use Test::More; + +BEGIN { use_ok 'PerlIO::via::File::KDBX::HashBlock' } + +{ + my $expected_plaintext = 'Tiny food from Spain!'; + + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + PerlIO::via::File::KDBX::HashBlock->push($write, block_size => 3); + print $write $expected_plaintext; + binmode($write, ':pop'); # finish stream + close($write) or die "close failed: $!"; + + PerlIO::via::File::KDBX::HashBlock->push($read); + my $plaintext = do { local $/; <$read> }; + close($read); + + 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; + + my $expected_plaintext = "\x64" x (1024*1024*12 - 57); + + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + defined(my $pid = fork) or die "fork failed: $!\n"; + if ($pid == 0) { + PerlIO::via::File::KDBX::HashBlock->push($write); + print $write $expected_plaintext; + binmode($write, ':pop'); # finish stream + close($write) or die "close failed: $!"; + exit; + } + + PerlIO::via::File::KDBX::HashBlock->push($read); + my $plaintext = do { local $/; <$read> }; + close($read); + + is $plaintext, $expected_plaintext, 'Hash-block a lot'; + + waitpid($pid, 0) or die "wait failed: $!\n"; +} + +done_testing; diff --git a/t/hmac-block.t b/t/hmac-block.t new file mode 100644 index 0000000..bff3d5e --- /dev/null +++ b/t/hmac-block.t @@ -0,0 +1,75 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon qw(:no_warnings_test); + +use File::KDBX::Util qw(can_fork); +use IO::Handle; +use Test::More; + +BEGIN { use_ok 'PerlIO::via::File::KDBX::HmacBlock' } + +my $KEY = "\x01" x 64; + +{ + my $expected_plaintext = 'Tiny food from Spain!'; + + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + PerlIO::via::File::KDBX::HmacBlock->push($write, block_size => 3, key => $KEY); + print $write $expected_plaintext; + binmode($write, ':pop'); # finish stream + close($write) or die "close failed: $!"; + + PerlIO::via::File::KDBX::HmacBlock->push($read, key => $KEY); + my $plaintext = do { local $/; <$read> }; + close($read); + + 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; + + my $expected_plaintext = "\x64" x (1024*1024*12 - 57); + + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + defined(my $pid = fork) or die "fork failed: $!\n"; + if ($pid == 0) { + PerlIO::via::File::KDBX::HmacBlock->push($write, key => $KEY); + print $write $expected_plaintext; + binmode($write, ':pop'); # finish stream + close($write) or die "close failed: $!"; + exit; + } + + PerlIO::via::File::KDBX::HmacBlock->push($read, key => $KEY); + my $plaintext = do { local $/; <$read> }; + close($read); + + is $plaintext, $expected_plaintext, 'HMAC-block a lot'; + + waitpid($pid, 0) or die "wait failed: $!\n"; +} + +done_testing; diff --git a/t/kdb.t b/t/kdb.t new file mode 100644 index 0000000..ab4fea4 --- /dev/null +++ b/t/kdb.t @@ -0,0 +1,198 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use Encode qw(decode); +use File::KDBX; +use Test::Deep; +use Test::More; + +eval { require File::KeePass; require File::KeePass::KDBX } + or plan skip_all => 'File::KeePass and File::KeePass::KDBX required to test KDB files'; + +my $kdbx = File::KDBX->load(testfile('basic.kdb'), 'masterpw'); + +sub test_basic { + my $kdbx = shift; + + cmp_deeply $kdbx->headers, superhashof({ + cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377", + encryption_iv => "\250\354q\362\13\247\353\247\222!\232\364Lj\315w", + master_seed => "\212z\356\256\340+\n\243ms2\364'!7\216", + transform_rounds => 713, + transform_seed => "\227\264\n^\230\2\301:!f\364\336\251\277\241[\3`\314RG\343\16U\333\305eT3:\240\257", + }), 'Get expected headers from KDB file' or diag explain $kdbx->headers; + + is keys %{$kdbx->deleted_objects}, 0, 'There are no deleted objects'; + is scalar @{$kdbx->root->groups}, 2, 'Root group has two children.'; + + my $group1 = $kdbx->root->groups->[0]; + isnt $group1->uuid, undef, 'Group 1 has a UUID'; + is $group1->name, 'Internet', 'Group 1 has a name'; + is scalar @{$group1->groups}, 2, 'Group 1 has subgroups'; + is scalar @{$group1->entries}, 2, 'Group 1 has entries'; + is $group1->icon_id, 1, 'Group 1 has an icon'; + + my ($entry11, $entry12, @other) = @{$group1->entries}; + + isnt $entry11->uuid, undef, 'Entry has a UUID'; + is $entry11->title, 'Test entry', 'Entry has a title'; + is $entry11->icon_id, 1, 'Entry has an icon'; + is $entry11->username, 'I', 'Entry has a username'; + is $entry11->url, 'http://example.com/', 'Entry has a URL'; + is $entry11->password, 'secretpassword', 'Entry has a password'; + is $entry11->notes, "Lorem ipsum\ndolor sit amet", 'Entry has notes'; + ok $entry11->expires, 'Entry is expired'; + is $entry11->expiry_time, 'Wed May 9 10:32:00 2012', 'Entry has an expiration time'; + is scalar keys %{$entry11->binaries}, 1, 'Entry has a binary'; + is $entry11->binary_value('attachment.txt'), "hello world\n", 'Entry has a binary'; + + is $entry12->title, '', 'Entry 2 has an empty title'; + is $entry12->icon_id, 0, 'Entry 2 has an icon'; + is $entry12->username, '', 'Entry 2 has an empty username'; + is $entry12->url, '', 'Entry 2 has an empty URL'; + is $entry12->password, '', 'Entry 2 has an empty password'; + is $entry12->notes, '', 'Entry 2 has empty notes'; + ok !$entry12->expires, 'Entry 2 is not expired'; + is scalar keys %{$entry12->binaries}, 0, 'Entry has no binaries'; + + my $group11 = $group1->groups->[0]; + is $group11->label, 'Subgroup 1', 'Group has subgroup'; + is scalar @{$group11->groups}, 1, 'Subgroup has subgroup'; + + my $group111 = $group11->groups->[0]; + is $group111->label, 'Unexpanded', 'Has unexpanded group'; + is scalar @{$group111->groups}, 1, 'Subgroup has subgroup'; + + my $group1111 = $group111->groups->[0]; + is $group1111->label, 'abc', 'Group has subsubsubroup'; + is scalar @{$group1111->groups}, 0, 'No more subgroups'; + + my $group12 = $group1->groups->[1]; + is $group12->label, 'Subgroup 2', 'Group has another subgroup'; + is scalar @{$group12->groups}, 0, 'No more subgroups'; + + my $group2 = $kdbx->root->groups->[1]; + is $group2->label, 'eMail', 'Root has another subgroup'; + is scalar @{$group2->entries}, 1, 'eMail group has an entry'; + is $group2->icon_id, 19, 'Group has a standard icon'; +} +for my $test ( + ['Basic' => $kdbx], + ['Basic after dump & load roundtrip' + => File::KDBX->load_string($kdbx->dump_string('a', randomize_seeds => 0), 'a')], +) { + my ($name, $kdbx) = @$test; + subtest $name, \&test_basic, $kdbx; +} + +sub test_custom_icons { + my $kdbx = shift; + + my ($uuid, @other) = keys %{$kdbx->custom_icons}; + ok $uuid, 'Database has a custom icon'; + is scalar @other, 0, 'Database has no other icons'; + + my $data = $kdbx->custom_icon_data($uuid); + like $data, qr/^\x89PNG\r\n/, 'Custom icon is a PNG'; +} +for my $test ( + ['Custom icons' => $kdbx], + ['Custom icons after dump & load roundtrip' + => File::KDBX->load_string($kdbx->dump_string('a', upgrade => 0, randomize_seeds => 0), 'a')], +) { + my ($name, $kdbx) = @$test; + subtest $name, \&test_custom_icons, $kdbx; +} + +subtest 'Group expansion' => sub { + is $kdbx->root->groups->[0]->is_expanded, 1, 'Group is expanded'; + is $kdbx->root->groups->[0]->groups->[0]->is_expanded, 1, 'Subgroup is expanded'; + is $kdbx->root->groups->[0]->groups->[0]->groups->[0]->is_expanded, 0, 'Subsubgroup is not expanded'; +}; + +subtest 'Autotype' => sub { + my $group = $kdbx->root->groups->[0]->groups->[0]; + is scalar @{$group->entries}, 2, 'Group has two entries'; + + my ($entry1, $entry2) = @{$group->entries}; + + is $entry1->notes, "\nlast line", 'First entry has a note'; + TODO: { + local $TODO = 'File::KeePass fails to parse out the default key sequence'; + is $entry1->auto_type->{default_sequence}, '{USERNAME}{ENTER}', 'First entry has a default sequence'; + }; + cmp_deeply $entry1->auto_type->{associations}, set( + { + keystroke_sequence => "{USERNAME}{ENTER}", + window => "a window", + }, + { + keystroke_sequence => "{USERNAME}{ENTER}", + window => "a second window", + }, + { + keystroke_sequence => "{PASSWORD}{ENTER}", + window => "Window Nr 1a", + }, + { + keystroke_sequence => "{PASSWORD}{ENTER}", + window => "Window Nr 1b", + }, + { + keystroke_sequence => "{USERNAME}{ENTER}", + window => "Window 2", + }, + ), 'First entry has auto-type window associations'; + + is $entry2->notes, "start line\nend line", 'Second entry has notes'; + TODO: { + local $TODO = 'File::KeePass fails to parse out the default key sequence'; + is $entry2->auto_type->{default_sequence}, '', 'Second entry has no default sequence'; + cmp_deeply $entry2->auto_type->{associations}, set( + { + keystroke_sequence => "", + window => "Main Window", + }, + { + keystroke_sequence => "", + window => "Test Window", + }, + ), 'Second entry has auto-type window associations' or diag explain $entry2->auto_type->{associations}; + }; +}; + +subtest 'KDB file keys' => sub { + while (@_) { + my ($name, $key) = splice @_, 0, 2; + my $kdb_filepath = testfile("$name.kdb"); + my $kdbx = File::KDBX->load($kdb_filepath, $key); + + is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name"; + } +}, ( + FileKeyBinary => {file => testfile('FileKeyBinary.key')}, + FileKeyHex => {file => testfile('FileKeyHex.key')}, + FileKeyHashed => {file => testfile('FileKeyHashed.key')}, + CompositeKey => ['mypassword', {file => testfile('FileKeyHex.key')}], +); + +subtest 'Twofish' => sub { + plan skip_all => 'File::KeePass does not implement the Twofish cipher'; + my $name = 'Twofish'; + my $kdbx = File::KDBX->load(testfile("$name.kdb"), 'masterpw'); + is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name"; +}; + +subtest 'CP-1252 password' => sub { + my $name = 'CP-1252'; + my $kdbx = File::KDBX->load(testfile("$name.kdb"), + decode('UTF-8', "\xe2\x80\x9e\x70\x61\x73\x73\x77\x6f\x72\x64\xe2\x80\x9d")); + is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name"; +}; + +done_testing; diff --git a/t/kdbx2.t b/t/kdbx2.t new file mode 100644 index 0000000..958348a --- /dev/null +++ b/t/kdbx2.t @@ -0,0 +1,100 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX; +use File::KDBX::Constants qw(:version :kdf); +use Test::Deep; +use Test::More; + +my $kdbx = File::KDBX->load(testfile('Format200.kdbx'), 'a'); + +verify_kdbx2($kdbx, KDBX_VERSION_2_0); +is $kdbx->kdf->uuid, KDF_UUID_AES, 'KDBX2 file has a usable KDF configured'; + +my $dump; +like warning { $dump = $kdbx->dump_string('a', randomize_seeds => 0) }, qr/upgrading database/i, + 'There is a warning about a change in file version when writing'; + +my $kdbx_from_dump = File::KDBX->load_string($dump, 'a'); +verify_kdbx2($kdbx_from_dump, KDBX_VERSION_3_1); +is $kdbx->kdf->uuid, KDF_UUID_AES, 'New KDBX3 file has the same KDF'; + +sub verify_kdbx2 { + my $kdbx = shift; + my $vers = shift; + + ok_magic $kdbx, $vers, 'Get the correct KDBX2 file magic'; + + cmp_deeply $kdbx->headers, superhashof({ + cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377", + compression_flags => 1, + encryption_iv => "D+VZ\277\274>\226K\225\3237\255\231\35\4", + inner_random_stream_id => 2, + inner_random_stream_key => "\214\aW\253\362\177<\346n`\263l\245\353T\25\261BnFp\177\357\335\36(b\372z\231b\355", + kdf_parameters => { + "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352", + R => 6000, + S => "S\202\207A\3475\265\177\220\331\263[\334\326\365\324B\\\2222zb-f\263m\220\333S\361L\332", + }, + master_seed => "\253!\2\241\r*|{\227\0276Lx\215\32\\\17\372d\254\255*\21r\376\251\313+gMI\343", + stream_start_bytes => "\24W\24\3262oU\t>\242B\2666:\231\377\36\3\353 \217M\330U\35\367|'\230\367\221^", + }), 'Get expected headers from KDBX2 file' or diag explain $kdbx->headers; + + cmp_deeply $kdbx->meta, superhashof({ + custom_data => {}, + database_description => "", + database_description_changed => obj_isa('Time::Piece'), + database_name => "", + database_name_changed => obj_isa('Time::Piece'), + default_username => "", + default_username_changed => obj_isa('Time::Piece'), + entry_templates_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", + entry_templates_group_changed => obj_isa('Time::Piece'), + generator => ignore(), + last_selected_group => "\226Y\251\22\356zB\@\214\222ns\273a\263\221", + last_top_visible_group => "\226Y\251\22\356zB\@\214\222ns\273a\263\221", + maintenance_history_days => 365, + memory_protection => superhashof({ + protect_notes => bool(0), + protect_password => bool(0), + protect_title => bool(0), + protect_url => bool(1), + protect_username => bool(1), + }), + recycle_bin_changed => obj_isa('Time::Piece'), + recycle_bin_enabled => bool(1), + recycle_bin_uuid => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", + }), 'Get expected metadata from KDBX2 file' or diag explain $kdbx->meta; + + $kdbx->unlock; + + is scalar @{$kdbx->root->entries}, 1, 'Get one entry in root'; + + my $entry = $kdbx->root->entries->[0]; + is $entry->title, 'Sample Entry', 'Get the correct title'; + is $entry->username, 'User Name', 'Get the correct username'; + + cmp_deeply $entry->binaries, { + "myattach.txt" => { + value => "abcdefghijk", + }, + "test.txt" => { + value => "this is a test", + }, + }, 'Get two attachments from the entry' or diag explain $entry->binaries; + + my @history = @{$entry->history}; + is scalar @history, 2, 'Get two historical entries'; + is scalar keys %{$history[0]->binaries}, 0, 'First historical entry has no attachments'; + is scalar keys %{$history[1]->binaries}, 1, 'Second historical entry has one attachment'; + cmp_deeply $history[1]->binary('myattach.txt'), { + value => 'abcdefghijk', + }, 'The attachment has the correct content'; +} + +done_testing; diff --git a/t/kdbx3.t b/t/kdbx3.t new file mode 100644 index 0000000..847712d --- /dev/null +++ b/t/kdbx3.t @@ -0,0 +1,133 @@ +#!/usr/bin/env perl + +use utf8; +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX; +use File::KDBX::Constants qw(:version); +use Test::Deep; +use Test::More; + +subtest 'Verify Format300' => sub { + my $kdbx = File::KDBX->load(testfile('Format300.kdbx'), 'a'); + + ok_magic $kdbx, KDBX_VERSION_3_0, 'Get the correct KDBX3 file magic'; + + cmp_deeply $kdbx->headers, { + cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377", + compression_flags => 1, + encryption_iv => "\214\306\310\0322\a9P\230\306\253\326\17\214\344\255", + inner_random_stream_id => 2, + inner_random_stream_key => "\346\n8\2\322\264i\5\5\274\22\377+\16tB\353\210\1\2m\2U%\326\347\355\313\313\340A\305", + kdf_parameters => { + "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352", + R => 6000, + S => "\340\377\235\255\222o\1(\226m\373\tC{K\352\f\332M\302|~P\e\346J\@\275A\227\236\366", + }, + master_seed => "Z\230\355\353\2303\361\237-p\345\27nM\22<E\252\314k\20\257\302\343p\"y\5sfw ", + stream_start_bytes => "\276\277jI1_\325\a\375\22\3\366\2V\"\316\370\316E\250B\317\232\232\207K\345.P\256b/", + }, 'Extract headers' or diag explain $kdbx->headers; + + is $kdbx->meta->{database_name}, 'Test Database Format 0x00030000', 'Extract database name from meta'; + is $kdbx->root->name, 'Format300', 'Extract name of root group'; +}; + +subtest 'Verify NonAscii' => sub { + my $kdbx = File::KDBX->load(testfile('NonAscii.kdbx'), 'Δöض'); + + ok_magic $kdbx, KDBX_VERSION_3_1, 'Get the correct KDBX3 file magic'; + + cmp_deeply $kdbx->headers, { + cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377", + compression_flags => 0, + encryption_iv => "\264\256\210m\311\312s\274U\206\t^\202\323\365]", + inner_random_stream_id => 2, + inner_random_stream_key => "Z\244]\373\13`\2108=>\r\224\351\373\316\276\253\6\317z\356\302\36\fW\1776Q\366\32\34,", + kdf_parameters => { + "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352", + R => 6000, + S => "l\254\250\255\240U\313\364\336\316#\254\306\231\f%U\207J\235\275\34\b\25036\26\241\a\300\26\332", + }, + master_seed => "\13\350\370\214{\0276\17dv\31W[H\26\272\4\335\377\356\275N\"\2A1\364\213\226\237\303M", + stream_start_bytes => "\220Ph\27\"h\233^\263mf\3339\262U\313\236zF\f\23\b9\323\346=\272\305})\240T", + }, 'Extract headers' or diag explain $kdbx->headers; + + is $kdbx->meta->{database_name}, 'NonAsciiTest', 'Extract database name from meta'; +}; + +subtest 'Verify Compressed' => sub { + my $kdbx = File::KDBX->load(testfile('Compressed.kdbx'), ''); + + ok_magic $kdbx, KDBX_VERSION_3_1, 'Get the correct KDBX3 file magic'; + + cmp_deeply $kdbx->headers, { + cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377", + compression_flags => 1, + encryption_iv => "Z(\313\342\212x\f\326\322\342\313\320\352\354:S", + inner_random_stream_id => 2, + inner_random_stream_key => "+\232\222\302\20\333\254\342YD\371\34\373,\302:\303\247\t\26\$\a\370g\314\32J\240\371;U\234", + kdf_parameters => { + "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352", + R => 6000, + S => "\3!\230hx\363\220nV\23\340\316\262\210\26Z\al?\343\240\260\325\262\31i\223y\b\306\344V", + }, + master_seed => "\0206\244\265\203m14\257T\372o\16\271\306\347\215\365\376\304\20\356\344\3713\3\303\363\a\5\205\325", + stream_start_bytes => "i%Ln\30\r\261\212Q\266\b\201\et\342\203\203\374\374E\303\332\277\320\13\304a\223\215#~\266", + }, 'Extract headers' or diag explain $kdbx->headers; + + is $kdbx->meta->{database_name}, 'Compressed', 'Extract database name from meta'; +}; + +subtest 'Verify ProtectedStrings' => sub { + my $kdbx = File::KDBX->load(testfile('ProtectedStrings.kdbx'), 'masterpw'); + + ok_magic $kdbx, KDBX_VERSION_3_1, 'Get the correct KDBX3 file magic'; + + cmp_deeply $kdbx->headers, { + cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377", + compression_flags => 1, + encryption_iv => "\0177y\356&\217\215\244\341\312\317Z\246m\363\251", + inner_random_stream_id => 2, + inner_random_stream_key => "%M\333Z\345\22T\363\257\27\364\206\352\334\r\3\361\250\360\314\213\253\237\23B\252h\306\243(7\13", + kdf_parameters => ignore(), + kdf_parameters => { + "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352", + R => 6000, + S => "y\251\327\312mW8B\351\273\364#T#m:\370k1\240v\360E\245\304\325\265\313\337\245\211E", + }, + master_seed => "\355\32<1\311\320\315\24\204\325\250\35+\2525\321\224x?\361\355\310V\322\20\331\324\"\372\334\210\233", + stream_start_bytes => "D#\337\260,\340.\276\312\302N\336y\233\275\360\250|\272\346*.\360\256\232\220\263>\303\aQ\371", + }, 'Extract headers' or diag explain $kdbx->headers; + + is $kdbx->meta->{database_name}, 'Protected Strings Test', 'Extract database name from meta'; + + $kdbx->unlock; + + my ($entry) = @{$kdbx->all_entries}; + is $entry->title, 'Sample Entry', 'Get entry title'; + is $entry->username, 'Protected User Name', 'Get protected username from entry'; + is $entry->password, 'ProtectedPassword', 'Get protected password from entry'; + is $entry->string_value('TestProtected'), 'ABC', 'Get ABC string from entry'; + is $entry->string_value('TestUnprotected'), 'DEF', 'Get DEF string from entry'; + + ok $kdbx->meta->{memory_protection}{protect_password}, 'Memory protection is ON for passwords'; + ok $entry->string('TestProtected')->{protect}, 'Protection is ON for TestProtected'; + ok !$entry->string('TestUnprotected')->{protect}, 'Protection is OFF for TestUnprotected'; +}; + +subtest 'Verify BrokenHeaderHash' => sub { + like exception { File::KDBX->load(testfile('BrokenHeaderHash.kdbx'), '') }, + qr/header hash does not match/i, 'Fail to load a database with a corrupted header hash'; +}; + +subtest 'Dump and load' => sub { + my $kdbx = File::KDBX->new; + my $dump = $kdbx->dump_string('foo'); + ok $dump; +}; + +done_testing; diff --git a/t/kdbx4.t b/t/kdbx4.t new file mode 100644 index 0000000..663a1b8 --- /dev/null +++ b/t/kdbx4.t @@ -0,0 +1,219 @@ +#!/usr/bin/env perl + +use utf8; +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX; +use File::KDBX::Constants qw(:version :kdf); +use Test::Deep; +use Test::More; +use boolean qw(:all); + +subtest 'Verify Format400' => sub { + my $kdbx = File::KDBX->load(testfile('Format400.kdbx'), 't'); + $kdbx->unlock; + + ok_magic $kdbx, KDBX_VERSION_4_0, 'Get the correct KDBX4 file magic'; + + cmp_deeply $kdbx->headers, { + cipher_id => "\326\3\212+\213oL\265\245\$3\2321\333\265\232", + compression_flags => 1, + encryption_iv => "3?\207P\233or\220\215h\2240", + kdf_parameters => { + "\$UUID" => "\357cm\337\214)DK\221\367\251\244\3\343\n\f", + I => 2, + M => 1048576, + P => 2, + S => "V\254\6m-\206*\260\305\f\0\366\24:4\235\364A\362\346\221\13)}\250\217P\303\303\2\331\245", + V => 19, + }, + master_seed => ";\372y\300yS%\3331\177\231\364u\265Y\361\225\3273h\332R,\22\240a\240\302\271\357\313\23", + }, 'Extract headers' or diag explain $kdbx->headers; + + is $kdbx->meta->{database_name}, 'Format400', 'Extract database name from meta'; + is $kdbx->root->name, 'Format400', 'Extract name of root group'; + + my ($entry, @other) = $kdbx->find_entries([\'400', 'title']); + is @other, 0, 'Database has one entry'; + + is $entry->title, 'Format400', 'Entry is titled'; + is $entry->username, 'Format400', 'Entry has a username set'; + is keys %{$entry->strings}, 6, 'Entry has six strings'; + is $entry->string_value('Format400'), 'Format400', 'Entry has a custom string'; + is keys %{$entry->binaries}, 1, 'Entry has one binary'; + is $entry->binary_value('Format400'), "Format400\n", 'Entry has a binary string'; +}; + +subtest 'KDBX4 upgrade' => sub { + my $kdbx = File::KDBX->new; + + $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_AES_CHALLENGE_RESPONSE; + is $kdbx->minimum_version, KDBX_VERSION_4_0, 'AES challenge-response KDF requires upgrade'; + $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_ARGON2D; + is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Argon2D KDF requires upgrade'; + $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_ARGON2ID; + is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Argon2ID KDF requires upgrade'; + $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_AES; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $kdbx->public_custom_data->{foo} = 42; + is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Public custom data requires upgrade'; + delete $kdbx->public_custom_data->{foo}; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + my $entry = $kdbx->add_entry; + $entry->custom_data(foo => 'bar'); + is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Entry custom data requires upgrade'; + delete $entry->custom_data->{foo}; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + my $group = $kdbx->add_group; + $group->custom_data(foo => 'bar'); + is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Group custom data requires upgrade'; + delete $group->custom_data->{foo}; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; +}; + +subtest 'KDBX4.1 upgrade' => sub { + my $kdbx = File::KDBX->new; + + my $group1 = $kdbx->add_group; + my $group2 = $kdbx->add_group; + my $entry1 = $kdbx->add_entry; + + $group1->tags('hi'); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Groups with tags requires upgrade'; + $group1->tags(''); + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $entry1->quality_check(0); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Disable entry quality check requires upgrade'; + $entry1->quality_check(1); + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $group1->previous_parent_group($group2->uuid); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Previous parent group on group requires upgrade'; + $group1->previous_parent_group(undef); + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $entry1->previous_parent_group($group2->uuid); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Previous parent group on entry requires upgrade'; + $entry1->previous_parent_group(undef); + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $kdbx->add_custom_icon('data'); + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Icon with no metadata requires no upgrade'; + my $icon_uuid = $kdbx->add_custom_icon('data2', name => 'icon name'); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Icon with name requires upgrade'; + delete $kdbx->custom_icons->{$icon_uuid}; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + $icon_uuid = $kdbx->add_custom_icon('data2', last_modification_time => gmtime); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Icon with modtime requires upgrade'; + delete $kdbx->custom_icons->{$icon_uuid}; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $entry1->custom_data(foo => 'bar', last_modification_time => scalar gmtime); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Entry custom data modtime requires upgrade'; + delete $entry1->custom_data->{foo}; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $group1->custom_data(foo => 'bar', last_modification_time => scalar gmtime); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Group custom data modtime requires upgrade'; + delete $group1->custom_data->{foo}; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; +}; + +sub test_upgrade_master_key_integrity { + my ($modifier, $expected_version) = @_; + plan tests => $expected_version >= KDBX_VERSION_4_0 ? 6 : 5; + + my $kdbx = File::KDBX->new; + $kdbx->kdf_parameters(fast_kdf); + + is $kdbx->kdf->uuid, KDF_UUID_AES, 'Default KDF is AES'; + + { + local $_ = $kdbx; + $modifier->($kdbx); + } + is $kdbx->minimum_version, $expected_version, + sprintf('Got expected minimum version after modification: %x', $kdbx->minimum_version); + + my $master_key = ['fffqcvq4rc', \'this is a keyfile', sub { 'chalresp 523rf2' }]; + my $dump; + warnings { $kdbx->dump_string(\$dump, $master_key) }; + ok $dump, 'Can dump the database' or diag explain $dump; + + like exception { File::KDBX->load_string($dump, 'wrong key') }, + qr/invalid credentials/i, 'Cannot load a KDBX with the wrong key'; + + # print STDERR "DUMP: [$dump]\n"; + + my $kdbx2 = File::KDBX->load_string($dump, $master_key); + + is $kdbx2->version, $expected_version, sprintf('Got expected version: %x', $kdbx2->version); + isnt $kdbx2->kdf->uuid, KDF_UUID_AES, 'No unexpected KDF' if $kdbx2->version >= KDBX_VERSION_4_0; + + # diag explain(File::KDBX->load_string($dump, $master_key, inner_format => 'Raw')->raw); +} +for my $test ( + [KDBX_VERSION_3_1, 'nothing', sub {}], + [KDBX_VERSION_3_1, 'AES KDF', sub { $_->kdf_parameters(fast_kdf(KDF_UUID_AES)) }], + [KDBX_VERSION_4_0, 'Argon2D KDF', sub { $_->kdf_parameters(fast_kdf(KDF_UUID_ARGON2D)) }], + [KDBX_VERSION_4_0, 'Argon2ID KDF', sub { $_->kdf_parameters(fast_kdf(KDF_UUID_ARGON2ID)) }], + [KDBX_VERSION_4_0, 'public custom data', sub { $_->public_custom_data->{foo} = 'bar' }], + [KDBX_VERSION_3_1, 'custom data', sub { $_->custom_data(foo => 'bar') }], + [KDBX_VERSION_4_0, 'root group custom data', sub { $_->root->custom_data(baz => 'qux') }], + [KDBX_VERSION_4_0, 'group custom data', sub { $_->add_group->custom_data(baz => 'qux') }], + [KDBX_VERSION_4_0, 'entry custom data', sub { $_->add_entry->custom_data(baz => 'qux') }], +) { + my ($expected_version, $name, $modifier) = @$test; + subtest "Master key integrity: $name" => \&test_upgrade_master_key_integrity, + $modifier, $expected_version; +} + +subtest 'Custom data' => sub { + my $kdbx = File::KDBX->new; + $kdbx->kdf_parameters(fast_kdf(KDF_UUID_AES)); + $kdbx->version(KDBX_VERSION_4_0); + + $kdbx->public_custom_data->{str} = '你好'; + $kdbx->public_custom_data->{num} = 42; + $kdbx->public_custom_data->{bool} = true; + $kdbx->public_custom_data->{bytes} = "\1\2\3\4"; + + my $group = $kdbx->add_group(label => 'Group'); + $group->custom_data(str => '你好'); + $group->custom_data(num => 42); + $group->custom_data(bool => true); + + my $entry = $kdbx->add_entry(label => 'Entry'); + $entry->custom_data(str => '你好'); + $entry->custom_data(num => 42); + $entry->custom_data(bool => false); + + my $dump = $kdbx->dump_string('a'); + my $kdbx2 = File::KDBX->load_string($dump, 'a'); + + is $kdbx2->public_custom_data->{str}, '你好', 'Store a string in public custom data'; + cmp_ok $kdbx2->public_custom_data->{num}, '==', 42, 'Store a number in public custom data'; + is $kdbx2->public_custom_data->{bool}, true, 'Store a boolean in public custom data'; + ok isBoolean($kdbx2->public_custom_data->{bool}), 'Boolean is indeed a boolean'; + is $kdbx2->public_custom_data->{bytes}, "\1\2\3\4", 'Store some bytes in public custom data'; + + my ($group2) = $kdbx2->find_groups({label => 'Group'}); + is_deeply $group2->custom_data_value('str'), '你好', 'Store a string in group custom data'; + is_deeply $group2->custom_data_value('num'), '42', 'Store a number in group custom data'; + is_deeply $group2->custom_data_value('bool'), '1', 'Store a boolean in group custom data'; + + my ($entry2) = $kdbx2->find_entries({label => 'Entry'}); + is_deeply $entry2->custom_data_value('str'), '你好', 'Store a string in entry custom data'; + is_deeply $entry2->custom_data_value('num'), '42', 'Store a number in entry custom data'; + is_deeply $entry2->custom_data_value('bool'), '0', 'Store a boolean in entry custom data'; +}; + +done_testing; diff --git a/t/kdf-aes-pp.t b/t/kdf-aes-pp.t new file mode 100644 index 0000000..fa111e0 --- /dev/null +++ b/t/kdf-aes-pp.t @@ -0,0 +1,28 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +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'; + +my $r = $kdf->transform("\2" x 32); +is $r, "\342\234cp\375\\p\253]\213\f\246\345\230\266\260\r\222j\332Z\204:\322 p\224mhm\360\222", + 'AES KDF works without XS'; + +like exception { $kdf->transform("\2" x 33) }, qr/raw key must be 32 bytes/i, + 'Transformation requires valid arguments'; + +done_testing; diff --git a/t/kdf.t b/t/kdf.t new file mode 100644 index 0000000..372298d --- /dev/null +++ b/t/kdf.t @@ -0,0 +1,46 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Constants qw(: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); + is $result1, "\342\234cp\375\\p\253]\213\f\246\345\230\266\260\r\222j\332Z\204:\322 p\224mhm\360\222", + 'AES KDF basically works'; + + like exception { $kdf1->transform("\2" x 33) }, qr/raw key must be 32 bytes/i, + 'Transformation requires valid arguments'; +}; + +subtest 'Argon2 KDF' => sub { + my $kdf1 = File::KDBX::KDF->new( + uuid => KDF_UUID_ARGON2D, + salt => "\2" x 32, + iterations => 2, + parallelism => 2, + ); + my $r1 = $kdf1->transform("\2" x 32); + is $r1, "\352\333\247\347+x#\"C\340\224\30\316\350\3068E\246\347H\263\214V\310\5\375\16N.K\320\255", + 'Argon2D KDF works'; + + my $kdf2 = File::KDBX::KDF->new( + uuid => KDF_UUID_ARGON2ID, + salt => "\2" x 32, + iterations => 2, + parallelism => 3, + ); + my $r2 = $kdf2->transform("\2" x 32); + is $r2, "S\304\304u\316\311\202^\214JW{\312=\236\307P\345\253\323\313\23\215\247\210O!#F\16\1x", + 'Argon2ID KDF works'; +}; + +done_testing; diff --git a/t/keys.t b/t/keys.t new file mode 100644 index 0000000..0d03e65 --- /dev/null +++ b/t/keys.t @@ -0,0 +1,84 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use Crypt::Misc 0.029 qw(decode_b64 encode_b64); +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'; + is $pkey->raw_key, decode_b64('XohImNooBHFR0OVvjcYpJ3NgPQ1qq73WKhHvch0VQtg='), + 'Can calculate raw key from password' or diag encode_b64($pkey->raw_key); + + my $fkey = File::KDBX::Key->new(\'password'); + isa_ok $fkey, 'File::KDBX::Key::File'; + is $fkey->raw_key, decode_b64('XohImNooBHFR0OVvjcYpJ3NgPQ1qq73WKhHvch0VQtg='), + 'Can calculate raw key from file' or diag encode_b64($fkey->raw_key); + + my $ckey = File::KDBX::Key->new([ + $pkey, + $fkey, + 'another password', + File::KDBX::Key::File->new(testfile(qw{keys hashed.key})), + ]); + isa_ok $ckey, 'File::KDBX::Key::Composite'; + is $ckey->raw_key, decode_b64('FLV8/zOT9mEL8QKkzizq7mJflnb25ITblIPq608MGrk='), + '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'; + + my $buf = 'password'; + open(my $fh, '<', \$buf) or die "open failed: $!\n"; + + $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'; + + like exception { File::KDBX::Key::File->init }, + qr/^Missing key primitive/, 'Throws 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'; + + like exception { File::KDBX::Key::File->new({}) }, + qr/^Unexpected primitive type/, 'Throws if primitive is the wrong type'; +}; + +done_testing; diff --git a/t/lib/TestCommon.pm b/t/lib/TestCommon.pm new file mode 100644 index 0000000..3111460 --- /dev/null +++ b/t/lib/TestCommon.pm @@ -0,0 +1,102 @@ +package TestCommon; + +use warnings; +use strict; + +use Data::Dumper; +use File::KDBX::Constants qw(:magic :kdf); +use File::KDBX::Util qw(can_fork dumper); +use File::Spec::Functions qw(catfile); +use FindBin qw($Bin); +use Test::Fatal; +use Test::Deep; + +BEGIN { + $Data::Dumper::Deepcopy = 1; + $Data::Dumper::Deparse = 1; + $Data::Dumper::Indent = 1; + $Data::Dumper::Quotekeys = 0; + $Data::Dumper::Sortkeys = 1; + $Data::Dumper::Terse = 1; + $Data::Dumper::Trailingcomma = 1; + $Data::Dumper::Useqq = 1; +} + +sub import { + my $self = shift; + my @args = @_; + + my $caller = caller; + + require Test::Warnings; + my @warnings_flags; + push @warnings_flags, ':no_end_test' if !$ENV{AUTHOR_TESTING} || grep { $_ eq ':no_warnings_test' } @args; + Test::Warnings->import(@warnings_flags); + + # Just export a random assortment of things useful for testing. + no strict 'refs'; + *{"${caller}::dumper"} = \&File::KDBX::Util::dumper; + *{"${caller}::catfile"} = \&File::Spec::Functions::catfile; + + *{"${caller}::exception"} = \&Test::Fatal::exception; + *{"${caller}::warning"} = \&Test::Warnings::warning; + *{"${caller}::warnings"} = \&Test::Warnings::warnings; + + *{"${caller}::dump_test_deep_template"} = \&dump_test_deep_template; + *{"${caller}::ok_magic"} = \&ok_magic; + *{"${caller}::fast_kdf"} = \&fast_kdf; + *{"${caller}::can_fork"} = \&can_fork; + *{"${caller}::testfile"} = \&testfile; +} + +sub testfile { + return catfile($Bin, 'files', @_); +} + +sub dump_test_deep_template { + my $struct = shift; + + my $str = Dumper $struct; + # booleans: bless( do{\(my $o = 1)}, 'boolean' ) + $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/bool($1)/gs; + # objects + $str =~ s/bless\(.+?'([^']+)' \)/obj_isa('$1')/gs; + # convert two to four space indentation + $str =~ s/^( +)/' ' x (length($1) * 2)/gme; + + open(my $fh, '>>', 'TEST-DEEP-TEMPLATES.pl') or die "open failed: $!"; + print $fh $str, "\n"; +} + +sub ok_magic { + my $kdbx = shift; + my $vers = shift; + my $note = shift; + + my $magic = [$kdbx->sig1, $kdbx->sig2, $kdbx->version]; + cmp_deeply $magic, [ + KDBX_SIG1, + KDBX_SIG2_2, + $vers, + ], $note // 'KDBX magic numbers are correct'; +} + +sub fast_kdf { + my $uuid = shift // KDF_UUID_AES; + my $params = { + KDF_PARAM_UUID() => $uuid, + }; + if ($uuid eq KDF_UUID_AES || $uuid eq KDF_UUID_AES_CHALLENGE_RESPONSE) { + $params->{+KDF_PARAM_AES_ROUNDS} = 17; + $params->{+KDF_PARAM_AES_SEED} = "\1" x 32; + } + else { # Argon2 + $params->{+KDF_PARAM_ARGON2_SALT} = "\1" x 32; + $params->{+KDF_PARAM_ARGON2_PARALLELISM} = 1; + $params->{+KDF_PARAM_ARGON2_MEMORY} = 1 << 13; + $params->{+KDF_PARAM_ARGON2_ITERATIONS} = 2; + $params->{+KDF_PARAM_ARGON2_VERSION} = 0x13; + } + return $params; +} +1; diff --git a/t/memory-protection.t b/t/memory-protection.t new file mode 100644 index 0000000..328e28c --- /dev/null +++ b/t/memory-protection.t @@ -0,0 +1,305 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use Crypt::Digest qw(digest_data); +use Crypt::PRNG qw(random_bytes); +use Crypt::Misc qw(decode_b64); +use File::KDBX::Key; +use File::KDBX::Util qw(:erase :load); +use File::KDBX; +use IO::Handle; +use List::Util qw(max); +use POSIX (); +use Scalar::Util qw(looks_like_number); +use Scope::Guard; +use Test::More; + +BEGIN { + if (!$ENV{AUTHOR_TESTING}) { + plan skip_all => 'AUTHOR_TESTING required to test memory protection'; + exit; + } + if (!can_fork || !try_load_optional('POSIX::1003')) { + plan skip_all => 'fork and POSIX::1003 required to test memory protection'; + exit; + } + POSIX::1003->import(':rlimit'); +} + +my $BLOCK_SIZE = 8196; + +-e 'core' && die "Remove or move the core dump!\n"; +my $cleanup = Scope::Guard->new(sub { unlink('core') }); + +my ($cur, $max, $success) = getrlimit('RLIMIT_CORE'); +$success or die "getrlimit failed: $!\n"; +if ($cur < 1<<16) { + setrlimit('RLIMIT_CORE', RLIM_INFINITY, RLIM_INFINITY) or die "setrlimit failed: $!\n"; +} + +my $SECRET = 'c3VwZXJjYWxpZnJhZ2lsaXN0aWM='; +my $SECRET_SHA256 = 'y1cOWidI80n5EZQx24NrOiP9tlca/uNMBDLYciDyQxs='; + +for my $test ( + { + test => 'secret in scope', + run => sub { + my $secret = decode_b64($SECRET); + dump_core(); + }, + strings => [ + $SECRET => 1, + ], + }, + { + test => 'erased secret', + run => sub { + my $secret = decode_b64($SECRET); + erase $secret; + dump_core(); + }, + strings => [ + $SECRET => 0, + ], + }, + { + test => 'Key password', + run => sub { + my $password = decode_b64($SECRET); + my $key = File::KDBX::Key->new($password); + erase $password; + dump_core(); + }, + strings => [ + $SECRET => 0, + ], + }, + { + test => 'Key password, raw key shown', + run => sub { + my $password = decode_b64($SECRET); + my $key = File::KDBX::Key->new($password); + erase $password; + $key->show; + dump_core(); + }, + strings => [ + $SECRET => 0, + $SECRET_SHA256 => 1, + ], + }, + { + test => 'Key password, raw key hidden', + run => sub { + my $password = decode_b64($SECRET); + my $key = File::KDBX::Key->new($password); + erase $password; + $key->show->hide for 0..500; + dump_core(); + }, + strings => [ + $SECRET => 0, + $SECRET_SHA256 => 0, + ], + }, + { + test => 'protected strings and keys', + run => sub { + my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw'); + dump_core(); + }, + strings => [ + 'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 0, # Password + 'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 0, + # Secret A: + 'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 0, # Secret B + 'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret + 'SlHA3Eyhomr/UQ6vznWMRZtxlrqIm/tM3qVZv7G31DU=' => 0, # Final key + 'LuVqNfGluvLPcg2W699/Q6WGxIztX7Jvw0ONwQEi/Jc=' => 0, # Transformed key + # HMAC key: + 'kDEMVEcGR32UXTwG8j3SxsfdF+l124Ni6iHeogCWGd2z0KSG5PosDTloxC0zg7Ucn2CNR6f2wpgzcVGKmDNFCA==' => 0, + # Inner random stream key: + 'SwJSukmQdZKpHm8PywqLu1EHfUzS/gyJsg61Cm74YeRJeOpDlFblbVd5d4p+lU2/7Q28Vk4j/E2RRMC81DXdUw==' => 1, + 'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 1, # Random stream key (actual) + ], + }, + { + test => 'inner random stream key replaced', + run => sub { + my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw'); + $kdbx->inner_random_stream_key("\1" x 64); + dump_core(); + }, + strings => [ + # Inner random stream key: + # FIXME - there is second copy of this key somewhere... in another SvPV? + 'SwJSukmQdZKpHm8PywqLu1EHfUzS/gyJsg61Cm74YeRJeOpDlFblbVd5d4p+lU2/7Q28Vk4j/E2RRMC81DXdUw==' => undef, + ], + }, + { + test => 'protected strings revealed', + run => sub { + my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw'); + $kdbx->unlock; + dump_core(); + }, + strings => [ + 'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 1, # Password + # Secret A: + 'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 1, + 'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 1, # Secret B + 'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret + 'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 0, # Random stream key (actual) + ], + }, + { + test => 'protected strings previously-revealed', + run => sub { + my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw'); + $kdbx->unlock; + $kdbx->lock; + dump_core(); + }, + strings => [ + 'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 0, # Password + # Secret A: + 'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 0, + 'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 0, # Secret B + 'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret + 'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 0, # Random stream key (actual) + ], + }, +) { + my ($description, $run, $strings) = @$test{qw(test run strings)}; + + subtest "Dump core with $description" => sub { + my @strings = @_; + my $num_strings = @strings / 2; + plan tests => 2 + $num_strings * 2; + + my (@encoded_strings, @expected); + while (@strings) { + my ($string, $expected) = splice @strings, 0, 2; + push @encoded_strings, $string; + push @expected, $expected; + } + + my ($dumped, $has_core, @matches) = run_test($run, @encoded_strings); + + ok $dumped, 'Test process signaled that it core-dumped'; + ok $has_core, 'Found core dump' or return; + + note sprintf('core dump is %.1f MiB', (-s 'core')/1048576); + + for (my $i = 1; $i <= $num_strings; ++$i) { + my $count = $matches[$i - 1]; + my $string = $encoded_strings[$i - 1]; + my $expected = $expected[$i - 1]; + + ok defined $count, "[#$i] Got result from test environment"; + + TODO: { + local $TODO = 'Unprotected memory!' if !defined $expected; + if ($expected) { + ok 0 < $count, "[#$i] String FOUND" + or diag "Found $count copies of string #$i\nString: $string"; + } + else { + is $count, 0, "[#$i] String MISSING" + or diag "Found $count copies of string #$i\nString: $string"; + } + } + } + }, @$strings; +} + +done_testing; +exit; + +############################################################################## + +sub dump_core { kill 'QUIT', $$ } + +sub file_grep { + my $filepath = shift; + my @strings = @_; + + my $counter = 0; + my %counts = map { $_ => $counter++ } @strings; + my @counts = map { 0 } @strings; + + my $pattern = join('|', map { quotemeta($_) } @strings); + + my $overlap = (max map { length } @strings) - 1; + + open(my $fh, '<:raw', $filepath) or die "open failed: $!\n"; + + my $previous; + while (read $fh, my $block, $BLOCK_SIZE) { + substr($block, 0, 0, substr($previous, -$overlap)) if defined $previous; + + while ($block =~ /($pattern)/gs) { + ++$counts[$counts{$1}]; + } + $previous = substr($block, $overlap); + } + die "read error: $!" if $fh->error; + + return @counts; +} + +sub run_test { + my $code = shift; + my @strings = @_; + + my $seed = random_bytes(32); + + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + defined(my $pid = fork) or die "fork failed: $!\n"; + if (!$pid) { # child + close($read); + + my $exit_status = run_doomed_child($code, $seed); + my $dumped = $exit_status & 127 && $exit_status & 128; + + my @decoded_strings = map { decode_b64($_) } @strings; + + my @matches = file_grep('core', @decoded_strings); + print $write join('|', $dumped, -f 'core' ? 1 : 0, @matches); + close($write); + + POSIX::_exit(0); + } + + close($write); + my $results = do { local $/; <$read> }; + + waitpid($pid, 0); + my $exit_status = $? >> 8; + $exit_status == 0 or die "test environment exited non-zero: $exit_status\n"; + + return split(/\|/, $results); +} + +sub run_doomed_child { + my $code = shift; + my $seed = shift; + + unlink('core') or die "unlink failed: $!\n" if -f 'core'; + + defined(my $pid = fork) or die "fork failed: $!\n"; + if (!$pid) { # child + $code->(); + dump_core(); # doomed + POSIX::_exit(1); # paranoid + } + + waitpid($pid, 0); + return $?; +} diff --git a/t/object.t b/t/object.t new file mode 100644 index 0000000..749066d --- /dev/null +++ b/t/object.t @@ -0,0 +1,91 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Entry; +use File::KDBX::Util qw(:uuid); +use File::KDBX; +use Test::Deep; +use Test::More; + +subtest 'Cloning' => sub { + my $kdbx = File::KDBX->new; + my $entry = File::KDBX::Entry->new; + + my $copy = $entry->clone; + like exception { $copy->kdbx }, qr/disassociated/, 'Disassociated entry copy is also disassociated'; + cmp_deeply $copy, $entry, 'Disassociated entry and its clone are identical'; + + $entry->kdbx($kdbx); + $copy = $entry->clone; + is $entry->kdbx, $copy->kdbx, 'Associated entry copy is also associated'; + cmp_deeply $copy, $entry, 'Associated entry and its clone are identical'; + + my $txn = $entry->begin_work; + $entry->title('foo'); + $entry->username('bar'); + $entry->password('baz'); + $txn->commit; + + $copy = $entry->clone; + is @{$copy->history}, 1, 'Copy has a historical entry'; + cmp_deeply $copy, $entry, 'Entry with history and its clone are identical'; + + $copy = $entry->clone(history => 0); + is @{$copy->history}, 0, 'Copy excluding history has no history'; + + $copy = $entry->clone(new_uuid => 1); + isnt $copy->uuid, $entry->uuid, 'Entry copy with new UUID has a different UUID'; + + $copy = $entry->clone(reference_username => 1); + my $ref = sprintf('{REF:U@I:%s}', format_uuid($entry->uuid)); + is $copy->username, $ref, 'Copy has username reference'; + is $copy->expanded_username, $ref, 'Entry copy does not expand username because entry is not in database'; + + my $group = $kdbx->add_group(label => 'Passwords'); + $group->add_entry($entry); + is $copy->expanded_username, $entry->username, + 'Entry in database and its copy with username ref have same expanded username'; + + $copy = $entry->clone; + is @{$kdbx->all_entries}, 1, 'Still only one entry after cloning'; + + $copy = $entry->clone(parent => 1); + is @{$kdbx->all_entries}, 2, 'New copy added to database if clone with parent option'; + my ($e1, $e2) = @{$kdbx->all_entries}; + isnt $e1, $e2, 'Entry and its copy in the database are different objects'; + is $e1->title, $e2->title, 'Entry copy has the same title as the original entry'; + + $copy = $entry->clone(parent => 1, relabel => 1); + is @{$kdbx->all_entries}, 3, 'New copy added to database if clone with parent option'; + is $kdbx->all_entries->[2], $copy, 'New copy and new entry in the database match'; + is $kdbx->all_entries->[2]->title, "foo - Copy", 'New copy has a modified title'; + + $copy = $group->clone; + cmp_deeply $copy, $group, 'Group and its clone are identical'; + is @{$copy->entries}, 3, 'Group copy has as many entries as the original'; + is @{$copy->entries->[0]->history}, 1, 'Entry in group copy has history'; + + $copy = $group->clone(history => 0); + is @{$copy->entries}, 3, 'Group copy without history has as many entries as the original'; + is @{$copy->entries->[0]->history}, 0, 'Entry in group copy has no history'; + + $copy = $group->clone(entries => 0); + is @{$copy->entries}, 0, 'Group copy without entries has no entries'; + is $copy->name, 'Passwords', 'Group copy label is the same as the original'; + + $copy = $group->clone(relabel => 1); + is $copy->name, 'Passwords - Copy', 'Group copy relabeled from the original title'; + is @{$kdbx->all_entries}, 3, 'No new entries were added to the database'; + + $copy = $group->clone(relabel => 1, parent => 1); + is @{$kdbx->all_entries}, 6, 'Copy a group within parent doubles the number of entries in the database'; + isnt $group->entries->[0]->uuid, $copy->entries->[0]->uuid, + 'First entry in group and its copy are different'; +}; + +done_testing; diff --git a/t/otp.t b/t/otp.t new file mode 100644 index 0000000..25d2fd9 --- /dev/null +++ b/t/otp.t @@ -0,0 +1,165 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Entry; +use Test::More; + +eval { require Pass::OTP } or plan skip_all => 'Pass::OTP required to test one-time-passwords'; + +my $secret_txt = 'hello'; +my $secret_b32 = 'NBSWY3DP'; +my $secret_b64 = 'aGVsbG8='; +my $secret_hex = '68656c6c6f'; +my $when = 1655488780; + +for my $test ( + { + name => 'HOTP - Basic', + input => {otp => "otpauth://hotp/Issuer:user?secret=${secret_b32}&issuer=Issuer"}, + codes => [qw(029578 825147 676217)], + uri => 'otpauth://hotp/Issuer:user?secret=NBSWY3DP&issuer=Issuer', + }, + { + name => 'HOTP - Start from 42', + input => { + otp => "otpauth://hotp/Issuer:user?secret=${secret_b32}&issuer=Issuer", + 'HmacOtp-Counter' => 42, + }, + codes => [qw(528783 171971 115730)], + uri => 'otpauth://hotp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&counter=42', + }, + { + name => 'HOTP - 7 digits', + input => {otp => "otpauth://hotp/Issuer:user?secret=${secret_b32}&issuer=Issuer&digits=7"}, + codes => [qw(3029578 9825147 9676217)], + uri => 'otpauth://hotp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&digits=7', + }, + { + name => 'HOTP - KeePass 2 storage (Base32)', + input => {'HmacOtp-Secret-Base32' => $secret_b32}, + codes => [qw(029578 825147 676217)], + uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX', + }, + { + name => 'HOTP - KeePass 2 storage (Base64)', + input => {'HmacOtp-Secret-Base64' => $secret_b64}, + codes => [qw(029578 825147 676217)], + uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX', + }, + { + name => 'HOTP - KeePass 2 storage (Hex)', + input => {'HmacOtp-Secret-Hex' => $secret_hex}, + codes => [qw(029578 825147 676217)], + uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX', + }, + { + name => 'HOTP - KeePass 2 storage (Text)', + input => {'HmacOtp-Secret' => $secret_txt}, + codes => [qw(029578 825147 676217)], + uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX', + }, + { + name => 'HOTP - KeePass 2, start from 42', + input => {'HmacOtp-Secret' => $secret_txt, 'HmacOtp-Counter' => 42}, + codes => [qw(528783 171971 115730)], + uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&counter=42', + }, + { + name => 'HOTP - Non-default attributes', + input => {'HmacOtp-Secret' => $secret_txt, Title => 'Website', UserName => 'foo!?'}, + codes => [qw(029578 825147 676217)], + uri => 'otpauth://hotp/Website:foo%21%3F?secret=NBSWY3DP&issuer=Website', + }, +) { + my $entry = File::KDBX::Entry->new; + $entry->string($_ => $test->{input}{$_}) for keys %{$test->{input}}; + is $entry->hmac_otp_uri, $test->{uri}, "$test->{name}: Valid URI"; + for my $code (@{$test->{codes}}) { + my $counter = $entry->string_value('HmacOtp-Counter') || 'undef'; + is $entry->hmac_otp, $code, "$test->{name}: Valid OTP ($counter)"; + } +} + +for my $test ( + { + name => 'TOTP - Basic', + input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=30&digits=6&issuer=Issuer"}, + code => '875357', + uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer', + }, + { + name => 'TOTP - SHA256', + input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=30&algorithm=SHA256"}, + code => '630489', + uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&algorithm=SHA256', + }, + { + name => 'TOTP - 60s period', + input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=60&digits=6&issuer=Issuer"}, + code => '647601', + uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&period=60', + }, + { + name => 'TOTP - 7 digits', + input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=30&digits=7&issuer=Issuer"}, + code => '9875357', + uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&digits=7', + }, + { + name => 'TOTP - Steam', + input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&issuer=Issuer&encoder=steam"}, + code => '55YH2', + uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&encoder=steam', + }, + { + name => 'TOTP - KeePass 2 storage', + input => {'TimeOtp-Secret-Base32' => $secret_b32}, + code => '875357', + uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX', + }, + { + name => 'TOTP - KeePass 2 storage, SHA256', + input => {'TimeOtp-Secret-Base32' => $secret_b32, 'TimeOtp-Algorithm' => 'HMAC-SHA-256'}, + code => '630489', + uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&algorithm=SHA256', + }, + { + name => 'TOTP - KeePass 2 storage, 60s period', + input => {'TimeOtp-Secret-Base32' => $secret_b32, 'TimeOtp-Period' => '60'}, + code => '647601', + uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&period=60', + }, + { + name => 'TOTP - KeePass 2 storage, 7 digits', + input => {'TimeOtp-Secret-Base32' => $secret_b32, 'TimeOtp-Length' => '7'}, + code => '9875357', + uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&digits=7', + }, + { + name => 'TOTP - Non-default attributes', + input => {'TimeOtp-Secret-Base32' => $secret_b32, Title => 'Website', UserName => 'foo!?'}, + code => '875357', + uri => 'otpauth://totp/Website:foo%21%3F?secret=NBSWY3DP&issuer=Website', + }, +) { + my $entry = File::KDBX::Entry->new; + $entry->string($_ => $test->{input}{$_}) for keys %{$test->{input}}; + is $entry->time_otp_uri, $test->{uri}, "$test->{name}: Valid URI"; + is $entry->time_otp(now => $when), $test->{code}, "$test->{name}: Valid OTP"; +} + +{ + my $entry = File::KDBX::Entry->new; + $entry->string('TimeOtp-Secret-Base32' => $secret_b32); + $entry->string('TimeOtp-Secret' => 'wat'); + my $warning = warning { $entry->time_otp_uri }; + like $warning, qr/Found multiple/, 'Alert if redundant secrets' + or diag 'Warnings: ', explain $warning; +} + +done_testing; diff --git a/t/placeholders.t b/t/placeholders.t new file mode 100644 index 0000000..0b77510 --- /dev/null +++ b/t/placeholders.t @@ -0,0 +1,77 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Entry; +use File::KDBX; +use Test::More; + +my $kdbx = File::KDBX->new; + +my $entry1 = $kdbx->add_entry( + title => 'Foo', + username => 'User {TITLE}', +); +my $entry2 = $kdbx->add_entry( + title => 'Bar', + username => sprintf('{REF:U@I:%s}', $entry1->id), + notes => 'notes {URL}', + url => 'url {NOTES}', +); +my $entry3 = $kdbx->add_entry( + username => sprintf('{REF:U@I:%s}', $entry2->id), + password => 'lyric:%LYRIC%', + notes => '%MISSING% %% %NOT AVAR% %LYRIC%', +); + +is $entry1->expanded_username, 'User Foo', 'Basic placeholder expansion'; +is $entry2->expanded_username, 'User Foo', 'Reference to another entry'; +is $entry3->expanded_username, 'User Foo', 'Reference to another entry through another'; + +my $recursive_expected = 'url notes ' x 10 . 'url {NOTES}'; +my $recursive; +my $warning = warning { $recursive = $entry2->expanded_url }; +like $warning, qr/detected deep recursion/i, 'Deep recursion causes a warning' + or diag 'Warnings: ', explain $warning; +is $recursive, $recursive_expected, 'Recursive placeholders resolve to... something'; + +{ + my $entry = File::KDBX::Entry->new(url => 'http://example.com?{EXPLODE}'); + is $entry->expanded_url, 'http://example.com?{EXPLODE}', + 'Unhandled placeholders are not replaced'; + + local $File::KDBX::PLACEHOLDERS{EXPLODE} = sub { 'boom' }; + is $entry->expanded_url, 'http://example.com?boom', 'Custom placeholders can be set'; + + $entry->url('{eXplOde}!!'); + is $entry->expanded_url, 'boom!!', 'Placeholder tags are match case-insensitively'; +} + +{ + local $ENV{LYRIC} = 'I am the very model of a modern Major-General'; + is $entry3->expanded_password, "lyric:$ENV{LYRIC}", 'Environment variable placeholders'; + is $entry3->expanded_notes, qq{%MISSING% %% %NOT AVAR% $ENV{LYRIC}}, + 'Do not replace things that look like environment variables but are not'; +} + +{ + my $counter = 0; + local $File::KDBX::PLACEHOLDERS{'COUNTER'} = $File::KDBX::PLACEHOLDERS{'COUNTER:'} = sub { + (undef, my $arg) = @_; + return defined $arg ? $arg : ++$counter; + }; + my $entry4 = $kdbx->add_entry( + url => '{COUNTER} {USERNAME}', + username => '{COUNTER}x{COUNTER}y{COUNTER:-1}', + ); + like $entry4->expanded_username, qr/^1x1y-1$/, + 'Each unique placeholder is evaluated once'; + like $entry4->expanded_url, qr/^2 3x3y-1$/, + 'Each unique placeholder is evaluated once per string'; +} + +done_testing; diff --git a/t/query.t b/t/query.t new file mode 100644 index 0000000..c15a009 --- /dev/null +++ b/t/query.t @@ -0,0 +1,217 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Util qw(query search simple_expression_query); +use Test::Deep; +use Test::More; + +my $list = [ + { + id => 1, + name => 'Bob', + age => 34, + married => 1, + notes => 'Enjoys bowling on Thursdays', + }, + { + id => 2, + name => 'Ken', + age => 17, + married => 0, + notes => 'Eats dessert first', + color => '', + }, + { + id => 3, + name => 'Becky', + age => 25, + married => 1, + notes => 'Listens to rap music on repeat', + color => 'orange', + }, + { + id => 4, + name => 'Bobby', + age => 5, + notes => 'Loves candy and running around like a crazy person', + color => 'blue', + }, +]; + +subtest 'Declarative structure' => sub { + my $result = search($list, name => 'Bob'); + cmp_deeply $result, [shallow($list->[0])], 'Find Bob' + or diag explain $result; + + $result = search($list, name => 'Ken'); + cmp_deeply $result, [$list->[1]], 'Find Ken' + or diag explain $result; + + $result = search($list, age => 25); + cmp_deeply $result, [$list->[2]], 'Find Becky by age' + or diag explain $result; + + $result = search($list, {name => 'Becky', age => 25}); + cmp_deeply $result, [$list->[2]], 'Find Becky by name AND age' + or diag explain $result; + + $result = search($list, {name => 'Becky', age => 99}); + cmp_deeply $result, [], 'Miss Becky with wrong age' + or diag explain $result; + + $result = search($list, [name => 'Becky', age => 17]); + cmp_deeply $result, [$list->[1], $list->[2]], 'Find Ken and Becky with different criteria' + or diag explain $result; + + $result = search($list, name => 'Becky', age => 17); + cmp_deeply $result, [$list->[1], $list->[2]], 'Query list defaults to OR logic' + or diag explain $result; + + $result = search($list, age => {'>=', 18}); + cmp_deeply $result, [$list->[0], $list->[2]], 'Find adults' + or diag explain $result; + + $result = search($list, name => {'=~', qr/^Bob/}); + cmp_deeply $result, [$list->[0], $list->[3]], 'Find both Bobs' + or diag explain $result; + + $result = search($list, -and => [name => 'Becky', age => 99]); + cmp_deeply $result, [], 'Specify AND logic explicitly' + or diag explain $result; + + $result = search($list, {name => 'Becky', age => 99}); + cmp_deeply $result, [], 'Specify AND logic implicitly' + or diag explain $result; + + $result = search($list, '!' => 'married'); + cmp_deeply $result, [$list->[1], $list->[3]], 'Find unmarried (using normal operator)' + or diag explain $result; + + $result = search($list, -false => 'married'); + cmp_deeply $result, [$list->[1], $list->[3]], 'Find unmarried (using special operator)' + or diag explain $result; + + $result = search($list, -true => 'married'); + cmp_deeply $result, [$list->[0], $list->[2]], 'Find married persons (using special operator)' + or diag explain $result; + + $result = search($list, -not => {name => {'=~', qr/^Bob/}}); + cmp_deeply $result, [$list->[1], $list->[2]], 'What about Bob? Inverse a complex query' + or diag explain $result; + + $result = search($list, -nonempty => 'color'); + cmp_deeply $result, [$list->[2], $list->[3]], 'Find the colorful' + or diag explain $result; + + $result = search($list, color => {ne => undef}); + cmp_deeply $result, [$list->[2], $list->[3]], 'Find the colorful (compare to undef)' + or diag explain $result; + + $result = search($list, -empty => 'color'); + cmp_deeply $result, [$list->[0], $list->[1]], 'Find those without color' + or diag explain $result; + + $result = search($list, color => {eq => undef}); + cmp_deeply $result, [$list->[0], $list->[1]], 'Find those without color (compare to undef)' + or diag explain $result; + + $result = search($list, -defined => 'color'); + cmp_deeply $result, [$list->[1], $list->[2], $list->[3]], 'Find defined colors' + or diag explain $result; + + $result = search($list, -undef => 'color'); + cmp_deeply $result, [$list->[0]], 'Find undefined colors' + or diag explain $result; + + $result = search($list, + -and => [ + name => {'=~', qr/^Bob/}, + -and => { + name => {'ne', 'Bob'}, + }, + ], + -not => {'!' => 'Bobby'}, + ); + cmp_deeply $result, [$list->[3]], 'Complex query' + or diag explain $result; + + my $query = query(name => 'Ken'); + $result = search($list, $query); + cmp_deeply $result, [$list->[1]], 'Search using a pre-compiled query' + or diag explain $result; + + my $custom_query = sub { shift->{name} eq 'Bobby' }; + $result = search($list, $custom_query); + cmp_deeply $result, [$list->[3]], 'Search using a custom query subroutine' + or diag explain $result; +}; + +############################################################################## + +subtest 'Simple expressions' => sub { + my $simple_query = simple_expression_query('bob', qw{name notes}); + my $result = search($list, $simple_query); + cmp_deeply $result, [$list->[0], $list->[3]], 'Basic one-term expression' + or diag explain $result; + + $result = search($list, \'bob', qw{name notes}); + cmp_deeply $result, [$list->[0], $list->[3]], 'Basic one-term expression on search' + or diag explain $result; + + $simple_query = simple_expression_query(' Dessert ', qw{notes}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[1]], 'Whitespace is ignored' + or diag explain $result; + + $simple_query = simple_expression_query('to music', qw{notes}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[2]], 'Multiple terms' + or diag explain $result; + + $simple_query = simple_expression_query('"to music"', qw{notes}); + $result = search($list, $simple_query); + cmp_deeply $result, [], 'One quoted term' + or diag explain $result; + + $simple_query = simple_expression_query('candy "CRAZY PERSON" ', qw{notes}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[3]], 'Multiple terms, one quoted term' + or diag explain $result; + + $simple_query = simple_expression_query(" bob\tcandy\n\n", qw{name notes}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[3]], 'Multiple terms in different fields' + or diag explain $result; + + $simple_query = simple_expression_query('music -repeat', qw{notes}); + $result = search($list, $simple_query); + cmp_deeply $result, [], 'Multiple terms, one negative term' + or diag explain $result; + + $simple_query = simple_expression_query('-bob', qw{name}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[1], $list->[2]], 'Negative term' + or diag explain $result; + + $simple_query = simple_expression_query('bob -bobby', qw{name}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[0]], 'Multiple mixed terms' + or diag explain $result; + + $simple_query = simple_expression_query(25, '==', qw{age}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[2]], 'Custom operator' + or diag explain $result; + + $simple_query = simple_expression_query('-25', '==', qw{age}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[0], $list->[1], $list->[3]], 'Negative term, custom operator' + or diag explain $result; +}; + +done_testing; diff --git a/t/references.t b/t/references.t new file mode 100644 index 0000000..9b31cfa --- /dev/null +++ b/t/references.t @@ -0,0 +1,52 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX; +use Test::More; + +my $kdbx = File::KDBX->new; +my $entry1 = $kdbx->add_entry( + title => 'Sun Valley Bank Inc.', + username => 'fred', + password => 'secr3t', +); +my $entry2 = $kdbx->add_entry( + title => 'Donut Shoppe', + username => 'freddy', + password => '1234', + testcustom => 'a custom string', +); +my $entry3 = $kdbx->add_entry( + title => 'Sun Clinic Inc.', + username => 'jerry', + password => 'password', + mycustom => 'this is another custom string', +); + +for my $test ( + ['{REF:U@T:donut}', 'freddy'], + ['U@T:donut', 'freddy'], + [[U => T => 'donut'], 'freddy', 'A reference can be pre-parsed parameters'], + + ['{REF:U@T:sun inc}', 'fred'], + ['{REF:U@T:"Sun Clinic Inc."}', 'jerry'], + + ['{REF:U@I:' . $entry2->id . '}', 'freddy', 'Resolve a field by UUID'], + + ['{REF:U@O:custom}', 'freddy'], + ['{REF:U@O:"another custom"}', 'jerry'], + + ['{REF:U@T:donut meh}', undef], + ['{REF:O@U:freddy}', undef], +) { + my ($ref, $expected, $note) = @$test; + $note //= "Reference: $ref"; + is $kdbx->resolve_reference(ref $ref eq 'ARRAY' ? @$ref : $ref), $expected, $note; +} + +done_testing; diff --git a/t/safe.t b/t/safe.t new file mode 100644 index 0000000..79d8e4c --- /dev/null +++ b/t/safe.t @@ -0,0 +1,63 @@ +#!/usr/bin/env perl + +use utf8; +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use Test::Deep; +use Test::More; + +BEGIN { use_ok 'File::KDBX::Safe' } + +my $secret = 'secret'; + +my @strings = ( + { + value => 'classified', + }, + { + value => 'bar', + meh => 'ignored', + }, + { + value => '你好', + }, +); + +my $safe = File::KDBX::Safe->new([@strings, \$secret]); +cmp_deeply \@strings, [ + { + value => undef, + }, + { + value => undef, + meh => 'ignored', + }, + { + value => undef, + }, +], 'Encrypt strings in a safe' or diag explain \@strings; +is $secret, undef, 'Scalar was set to undef'; + +my $val = $safe->peek($strings[1]); +is $val, 'bar', 'Peek at a string'; + +$safe->unlock; +cmp_deeply \@strings, [ + { + value => 'classified', + }, + { + value => 'bar', + meh => 'ignored', + }, + { + value => '你好', + }, +], 'Decrypt strings in a safe' or diag explain \@strings; +is $secret, 'secret', 'Scalar was set back to secret'; + +done_testing; diff --git a/t/util.t b/t/util.t new file mode 100644 index 0000000..54ed365 --- /dev/null +++ b/t/util.t @@ -0,0 +1,136 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +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 + dumper + empty + erase + erase_scoped + format_uuid + generate_uuid + gunzip + gzip + load_optional + nonempty + pad_pkcs7 + query + search + simple_expression_query + snakify + split_url + trim + uri_escape_utf8 + uri_unescape_utf8 + uuid +}); + +subtest 'Emptiness' => sub { + my @empty; + my @nonempty = 0; + ok empty(@empty), 'Empty array should be empty'; + ok !nonempty(@empty), 'Empty array should be !nonempty'; + ok !empty(@nonempty), 'Array should be !empty'; + ok nonempty(@nonempty), 'Array should be nonempty'; + + my %empty; + my %nonempty = (a => 'b'); + ok empty(%empty), 'Empty hash should be empty'; + ok !nonempty(%empty), 'Empty hash should be !nonempty'; + ok !empty(%nonempty), 'Hash should be !empty'; + ok nonempty(%nonempty), 'Hash should be nonempty'; + + my $empty = ''; + my $nonempty = '0'; + my $eref1 = \$empty; + my $eref2 = \$eref1; + my $nref1 = \$nonempty; + my $nref2 = \$nref1; + + for my $test ( + [0, $empty, 'Empty string'], + [0, undef, 'Undef'], + [0, \undef, 'Reference to undef'], + [0, {}, 'Empty hashref'], + [0, [], 'Empty arrayref'], + [0, $eref1, 'Reference to empty string'], + [0, $eref2, 'Reference to reference to empty string'], + [0, \\\\\\\'', 'Deep reference to empty string'], + [1, $nonempty, 'String'], + [1, 'hi', 'String'], + [1, 1, 'Number'], + [1, 0, 'Zero'], + [1, {a => 'b'}, 'Hashref'], + [1, [0], 'Arrayref'], + [1, $nref1, 'Reference to string'], + [1, $nref2, 'Reference to reference to string'], + [1, \\\\\\\'z', 'Deep reference to string'], + ) { + my ($expected, $thing, $note) = @$test; + if ($expected) { + ok !empty($thing), "$note should be !empty"; + ok nonempty($thing), "$note should be nonempty"; + } + else { + ok empty($thing), "$note should be empty"; + ok !nonempty($thing), "$note should be !nonempty"; + } + } +}; + +subtest 'UUIDs' => sub { + my $uuid = "\x01\x23\x45\x67\x89\xab\xcd\xef\x01\x23\x45\x67\x89\xab\xcd\xef"; + my $uuid1 = uuid('01234567-89AB-CDEF-0123-456789ABCDEF'); + my $uuid2 = uuid('0123456789ABCDEF0123456789ABCDEF'); + my $uuid3 = uuid('012-3-4-56-789AB-CDEF---012-34567-89ABC-DEF'); + + is $uuid1, $uuid, 'Formatted UUID is packed'; + is $uuid2, $uuid, 'Formatted UUID does not need dashes'; + is $uuid2, $uuid, 'Formatted UUID can have weird dashes'; + + is format_uuid($uuid), '0123456789ABCDEF0123456789ABCDEF', 'UUID unpacks to hex string'; + is format_uuid($uuid, '-'), '01234567-89AB-CDEF-0123-456789ABCDEF', 'Formatted UUID can be delimited'; + + my %uuid_set = ($uuid => 'whatever'); + + my $new_uuid = generate_uuid(\%uuid_set); + isnt $new_uuid, $uuid, 'Generated UUID is not in set'; + + $new_uuid = generate_uuid(sub { !$uuid_set{$_} }); + isnt $new_uuid, $uuid, 'Generated UUID passes a test function'; + + like generate_uuid(print => 1), qr/^[A-Za-z0-9]+$/, 'Printable UUID is printable (1)'; + like generate_uuid(printable => 1), qr/^[A-Za-z0-9]+$/, 'Printable UUID is printable (2)'; +}; + +subtest 'Snakification' => sub { + is snakify('FooBar'), 'foo_bar', 'Basic snakification'; + is snakify('MyUUIDSet'), 'my_uuid_set', 'Acronym snakification'; + is snakify('Numbers123'), 'numbers_123', 'Snake case with numbers'; + is snakify('456Baz'), '456_baz', 'Prefixed numbers'; +}; + +subtest 'Padding' => sub { + plan tests => 8; + + is pad_pkcs7('foo', 2), "foo\x01", 'Pad one byte to fill the second block'; + is pad_pkcs7('foo', 4), "foo\x01", 'Pad one byte to fill one block'; + is pad_pkcs7('foo', 8), "foo\x05\x05\x05\x05\x05", 'Pad to fill one block'; + is pad_pkcs7('moof', 4), "moof\x04\x04\x04\x04", 'Add a whole block of padding'; + is pad_pkcs7('', 3), "\x03\x03\x03", 'Pad an empty string'; + like exception { pad_pkcs7(undef, 8) }, qr/must provide a string/i, 'String must be defined'; + like exception { pad_pkcs7('bar') }, qr/must provide block size/i, 'Size must defined'; + like exception { pad_pkcs7('bar', 0) }, qr/must provide block size/i, 'Size must be non-zero'; +}; + +done_testing; diff --git a/t/yubikey.t b/t/yubikey.t new file mode 100644 index 0000000..1ec1ed4 --- /dev/null +++ b/t/yubikey.t @@ -0,0 +1,85 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use Test::More; + +BEGIN { use_ok 'File::KDBX::Key::YubiKey' } + +local $ENV{YKCHALRESP} = testfile(qw{bin ykchalresp}); +local $ENV{YKINFO} = testfile(qw{bin ykinfo}); + +{ + my ($pre, $post); + my $key = File::KDBX::Key::YubiKey->new( + pre_challenge => sub { ++$pre }, + post_challenge => sub { ++$post }, + ); + my $resp; + is exception { $resp = $key->challenge('foo') }, undef, + 'Do not throw during non-blocking response'; + is $resp, "\xf0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", 'Get a non-blocking challenge response'; + is length($resp), 20, 'Response is the proper length'; + is $pre, 1, 'The pre-challenge callback is called'; + is $post, 1, 'The post-challenge callback is called'; +} + +{ + my $key = File::KDBX::Key::YubiKey->new; + local $ENV{YKCHALRESP_MOCK} = 'error'; + like exception { $key->challenge('foo') }, qr/Yubikey core error:/i, + 'Throw if challenge-response program errored out'; +} + +{ + my $key = File::KDBX::Key::YubiKey->new; + local $ENV{YKCHALRESP_MOCK} = 'usberror'; + like exception { $key->challenge('foo') }, qr/USB error:/i, + 'Throw if challenge-response program had a USB error'; +} + +{ + my $key = File::KDBX::Key::YubiKey->new(timeout => 0, device => 3, slot => 2); + local $ENV{YKCHALRESP_MOCK} = 'block'; + + like exception { $key->challenge('foo') }, qr/operation would block/i, + 'Throw if challenge would block but we do not want to wait'; + + $key->timeout(1); + like exception { $key->challenge('foo') }, qr/timed out/i, + 'Timed out while waiting for response'; + + $key->timeout(-1); + my $resp; + is exception { $resp = $key->challenge('foo') }, undef, + 'Do not throw during blocking response'; + is $resp, "\xf0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", 'Get a blocking challenge response'; +} + +{ + my $key = File::KDBX::Key::YubiKey->new(device => 0, slot => 1); + is $key->name, 'YubiKey NEO FIDO v2.0.0 [123] (slot #1)', + 'Get name for a new, unscanned key'; + is $key->serial, 123, 'We have the serial number of the new key'; +} + +{ + my ($key, @other) = File::KDBX::Key::YubiKey->scan; + is $key->name, 'YubiKey 4/5 OTP v3.0.1 [456] (slot #2)', + 'Find expected YubiKey'; + is $key->serial, 456, 'We have the serial number of the scanned key'; + is scalar @other, 0, 'Do not find any other YubiKeys'; +} + +{ + local $ENV{YKCHALRESP} = testfile(qw{bin nonexistent}); + my $key = File::KDBX::Key::YubiKey->new; + like exception { $key->challenge('foo') }, qr/failed to run|failed to receive challenge response/i, + 'Throw if the program failed to run'; +} + +done_testing;