Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Loader/KDB.pm

   1 package File::KDBX::Loader::KDB;
   2 # ABSTRACT: Read KDB files
   3
   4 use warnings;
   5 use strict;
   6
   7 use Encode qw(encode);
   8 use File::KDBX::Constants qw(:header :cipher :random_stream :icon);
   9 use File::KDBX::Error;
  10 use File::KDBX::Util qw(:class :empty :io :uuid load_optional);
  11 use File::KDBX;
  12 use Ref::Util qw(is_arrayref is_hashref);
  13 use Scalar::Util qw(looks_like_number);
  14 use Time::Piece;
  15 use boolean;
  16 use namespace::clean;
  17
  18 extends 'File::KDBX::Loader';
  19
  20 our $VERSION = '0.902'; # VERSION
  21
  22 my $DEFAULT_EXPIRATION = Time::Piece->new(32503677839); # 2999-12-31 23:59:59
  23
  24 sub _read_headers { '' }
  25
  26 sub _read_body {
  27     my $self = shift;
  28     my $fh = shift;
  29     my $key = shift;
  30     my $buf = shift;
  31
  32     load_optional('File::KeePass');
  33
  34     $buf .= do { local $/; <$fh> };
  35
  36     $key = $self->kdbx->composite_key($key, keep_primitive => 1);
  37
  38     my $k = eval { File::KeePass->new->parse_db(\$buf, _convert_kdbx_to_keepass_master_key($key)) };
  39     if (my $err = $@) {
  40         throw 'Failed to parse KDB file', error => $err;
  41     }
  42
  43     $k->unlock;
  44     $self->kdbx->key($key);
  45
  46     return convert_keepass_to_kdbx($k, $self->kdbx);
  47 }
  48
  49 # This is also used by File::KDBX::Dumper::KDB.
  50 sub _convert_kdbx_to_keepass_master_key {
  51     my $key = shift;
  52
  53     my @keys = @{$key->keys};
  54     if (@keys == 1 && !$keys[0]->can('filepath')) {
  55         return [encode('CP-1252', $keys[0]->{primitive})];     # just a password
  56     }
  57     elsif (@keys == 1) {
  58         return [undef, \$keys[0]->raw_key]; # just a keyfile
  59     }
  60     elsif (@keys == 2 && !$keys[0]->can('filepath') && $keys[1]->can('filepath')) {
  61         return [encode('CP-1252', $keys[0]->{primitive}), \$keys[1]->raw_key];
  62     }
  63     throw 'Cannot use this key to load a KDB file', key => $key;
  64 }
  65
  66
  67 sub convert_keepass_to_kdbx {
  68     my $k    = shift;
  69     my $kdbx = shift // File::KDBX->new;
  70
  71     $kdbx->{headers} //= {};
  72     _convert_keepass_to_kdbx_headers($k->{header}, $kdbx);
  73
  74     my @groups = @{$k->{groups} || []};
  75     if (@groups == 1) {
  76         $kdbx->{root} = _convert_keepass_to_kdbx_group($k->{groups}[0]);
  77     }
  78     elsif (1 < @groups) {
  79         my $root = $kdbx->{root} = {%{File::KDBX->_implicit_root}};
  80         for my $group (@groups) {
  81             push @{$root->{groups} //= []}, _convert_keepass_to_kdbx_group($group);
  82         }
  83     }
  84
  85     $kdbx->entries
  86     ->grep({
  87         title       => 'Meta-Info',
  88         username    => 'SYSTEM',
  89         url         => '$',
  90         icon_id     => 0,
  91         -nonempty   => 'notes',
  92     })
  93     ->each(sub {
  94         _read_meta_stream($kdbx, $_);
  95         $_->remove(signal => 0);
  96     });
  97
  98     return $kdbx;
  99 }
 100
 101 sub _read_meta_stream {
 102     my $kdbx    = shift;
 103     my $entry   = shift;
 104
 105     my $type = $entry->notes;
 106     my $data = $entry->binary_value('bin-stream');
 107     open(my $fh, '<', \$data) or throw "Failed to open memory buffer for reading: $!";
 108
 109     if ($type eq 'KPX_GROUP_TREE_STATE') {
 110         read_all $fh, my $buf, 4 or goto PARSE_ERROR;
 111         my ($num) = unpack('L<', $buf);
 112         $num * 5 + 4 == length($data) or goto PARSE_ERROR;
 113         for (my $i = 0; $i < $num; ++$i) {
 114             read_all $fh, $buf, 5 or goto PARSE_ERROR;
 115             my ($group_id, $expanded) = unpack('L< C', $buf);
 116             my $uuid = _decode_uuid($group_id) // next;
 117             my $group = $kdbx->groups->grep({uuid => $uuid})->next;
 118             $group->is_expanded($expanded) if $group;
 119         }
 120     }
 121     elsif ($type eq 'KPX_CUSTOM_ICONS_4') {
 122         read_all $fh, my $buf, 12 or goto PARSE_ERROR;
 123         my ($num_icons, $num_entries, $num_groups) = unpack('L<3', $buf);
 124         my @icons;
 125         for (my $i = 0; $i < $num_icons; ++$i) {
 126             read_all $fh, $buf, 4 or goto PARSE_ERROR;
 127             my ($icon_size) = unpack('L<', $buf);
 128             read_all $fh, $buf, $icon_size or goto PARSE_ERROR;
 129             my $uuid = $kdbx->add_custom_icon($buf);
 130             push @icons, $uuid;
 131         }
 132         for (my $i = 0; $i < $num_entries; ++$i) {
 133             read_all $fh, $buf, 20 or goto PARSE_ERROR;
 134             my ($uuid, $icon_index) = unpack('a16 L<', $buf);
 135             next if !$icons[$icon_index];
 136             my $entry = $kdbx->entries->grep({uuid => $uuid})->next;
 137             $entry->custom_icon_uuid($icons[$icon_index]) if $entry;
 138         }
 139         for (my $i = 0; $i < $num_groups; ++$i) {
 140             read_all $fh, $buf, 8 or goto PARSE_ERROR;
 141             my ($group_id, $icon_index) = unpack('L<2', $buf);
 142             next if !$icons[$icon_index];
 143             my $uuid = _decode_uuid($group_id) // next;
 144             my $group = $kdbx->groups->grep({uuid => $uuid})->next;
 145             $group->custom_icon_uuid($icons[$icon_index]) if $group;
 146         }
 147     }
 148     else {
 149         alert "Ignoring unknown meta stream: $type\n", type => $type;
 150         return;
 151     }
 152
 153     return;
 154
 155     PARSE_ERROR:
 156     alert "Ignoring unparsable meta stream: $type\n", type => $type;
 157 }
 158
 159 sub _convert_keepass_to_kdbx_headers {
 160     my $from = shift;
 161     my $kdbx = shift;
 162
 163     my $headers = $kdbx->{headers} //= {};
 164     my $meta = $kdbx->{meta} //= {};
 165
 166     $kdbx->{sig1}       = $from->{sig1};
 167     $kdbx->{sig2}       = $from->{sig2};
 168     $kdbx->{version}    = $from->{vers};
 169
 170     my %enc_type = (
 171         rijndael    => CIPHER_UUID_AES256,
 172         aes         => CIPHER_UUID_AES256,
 173         twofish     => CIPHER_UUID_TWOFISH,
 174         chacha20    => CIPHER_UUID_CHACHA20,
 175         salsa20     => CIPHER_UUID_SALSA20,
 176         serpent     => CIPHER_UUID_SERPENT,
 177     );
 178     my $cipher_uuid = $enc_type{$from->{cipher} || ''} // $enc_type{$from->{enc_type} || ''};
 179
 180     my %protected_stream = (
 181         rc4         => STREAM_ID_RC4_VARIANT,
 182         salsa20     => STREAM_ID_SALSA20,
 183         chacha20    => STREAM_ID_CHACHA20,
 184     );
 185     my $protected_stream_id = $protected_stream{$from->{protected_stream} || ''} || STREAM_ID_SALSA20;
 186
 187     $headers->{+HEADER_COMMENT}                 = $from->{comment};
 188     $headers->{+HEADER_CIPHER_ID}               = $cipher_uuid if $cipher_uuid;
 189     $headers->{+HEADER_MASTER_SEED}             = $from->{seed_rand};
 190     $headers->{+HEADER_COMPRESSION_FLAGS}       = $from->{compression} // 0;
 191     $headers->{+HEADER_TRANSFORM_SEED}          = $from->{seed_key};
 192     $headers->{+HEADER_TRANSFORM_ROUNDS}        = $from->{rounds};
 193     $headers->{+HEADER_ENCRYPTION_IV}           = $from->{enc_iv};
 194     $headers->{+HEADER_INNER_RANDOM_STREAM_ID}  = $protected_stream_id;
 195     $headers->{+HEADER_INNER_RANDOM_STREAM_KEY} = $from->{protected_stream_key};
 196     $headers->{+HEADER_STREAM_START_BYTES}      = $from->{start_bytes} // '';
 197
 198     # TODO for KeePass 1 files these are all not available. Leave undefined or set default values?
 199     $meta->{memory_protection}{protect_notes}       = boolean($from->{protect_notes});
 200     $meta->{memory_protection}{protect_password}    = boolean($from->{protect_password});
 201     $meta->{memory_protection}{protect_username}    = boolean($from->{protect_username});
 202     $meta->{memory_protection}{protect_url}         = boolean($from->{protect_url});
 203     $meta->{memory_protection}{protect_title}       = boolean($from->{protect_title});
 204     $meta->{generator}                              = $from->{generator} // '';
 205     $meta->{header_hash}                            = $from->{header_hash};
 206     $meta->{database_name}                          = $from->{database_name} // '';
 207     $meta->{database_name_changed}                  = _decode_datetime($from->{database_name_changed});
 208     $meta->{database_description}                   = $from->{database_description} // '';
 209     $meta->{database_description_changed}           = _decode_datetime($from->{database_description_changed});
 210     $meta->{default_username}                       = $from->{default_user_name} // '';
 211     $meta->{default_username_changed}               = _decode_datetime($from->{default_user_name_changed});
 212     $meta->{maintenance_history_days}               = $from->{maintenance_history_days};
 213     $meta->{color}                                  = $from->{color};
 214     $meta->{master_key_changed}                     = _decode_datetime($from->{master_key_changed});
 215     $meta->{master_key_change_rec}                  = $from->{master_key_change_rec};
 216     $meta->{master_key_change_force}                = $from->{master_key_change_force};
 217     $meta->{recycle_bin_enabled}                    = boolean($from->{recycle_bin_enabled});
 218     $meta->{recycle_bin_uuid}                       = $from->{recycle_bin_uuid};
 219     $meta->{recycle_bin_changed}                    = _decode_datetime($from->{recycle_bin_changed});
 220     $meta->{entry_templates_group}                  = $from->{entry_templates_group};
 221     $meta->{entry_templates_group_changed}          = _decode_datetime($from->{entry_templates_group_changed});
 222     $meta->{last_selected_group}                    = $from->{last_selected_group};
 223     $meta->{last_top_visible_group}                 = $from->{last_top_visible_group};
 224     $meta->{history_max_items}                      = $from->{history_max_items};
 225     $meta->{history_max_size}                       = $from->{history_max_size};
 226     $meta->{settings_changed}                       = _decode_datetime($from->{settings_changed});
 227
 228     while (my ($key, $value) = each %{$from->{custom_icons} || {}}) {
 229         push @{$meta->{custom_icons} //= []}, {uuid => $key, data => $value};
 230     }
 231     while (my ($key, $value) = each %{$from->{custom_data} || {}}) {
 232         $meta->{custom_data}{$key} = {value => $value};
 233     }
 234
 235     return $kdbx;
 236 }
 237
 238 sub _convert_keepass_to_kdbx_group {
 239     my $from = shift;
 240     my $to   = shift // {};
 241     my %args = @_;
 242
 243     $to->{times}{last_access_time}          = _decode_datetime($from->{accessed});
 244     $to->{times}{usage_count}               = $from->{usage_count} || 0;
 245     $to->{times}{expiry_time}               = _decode_datetime($from->{expires}, $DEFAULT_EXPIRATION);
 246     $to->{times}{expires}                   = defined $from->{expires_enabled}
 247                                                 ? boolean($from->{expires_enabled})
 248                                                 : boolean($to->{times}{expiry_time} <= gmtime);
 249     $to->{times}{creation_time}             = _decode_datetime($from->{created});
 250     $to->{times}{last_modification_time}    = _decode_datetime($from->{modified});
 251     $to->{times}{location_changed}          = _decode_datetime($from->{location_changed});
 252     $to->{notes}                            = $from->{notes} // '';
 253     $to->{uuid}                             = _decode_uuid($from->{id});
 254     $to->{is_expanded}                      = boolean($from->{expanded});
 255     $to->{icon_id}                          = $from->{icon} // ICON_FOLDER;
 256     $to->{name}                             = $from->{title} // '';
 257     $to->{default_auto_type_sequence}       = $from->{auto_type_default} // '';
 258     $to->{enable_auto_type}                 = _decode_tristate($from->{auto_type_enabled});
 259     $to->{enable_searching}                 = _decode_tristate($from->{enable_searching});
 260     $to->{groups}                           = [];
 261     $to->{entries}                          = [];
 262
 263     if (!$args{shallow}) {
 264         for my $group (@{$from->{groups} || []}) {
 265             push @{$to->{groups}}, _convert_keepass_to_kdbx_group($group);
 266         }
 267         for my $entry (@{$from->{entries} || []}) {
 268             push @{$to->{entries}}, _convert_keepass_to_kdbx_entry($entry);
 269         }
 270     }
 271
 272     return $to;
 273 }
 274
 275 sub _convert_keepass_to_kdbx_entry {
 276     my $from = shift;
 277     my $to   = shift // {};
 278     my %args = @_;
 279
 280     $to->{times}{last_access_time}          = _decode_datetime($from->{accessed});
 281     $to->{times}{usage_count}               = $from->{usage_count} || 0;
 282     $to->{times}{expiry_time}               = _decode_datetime($from->{expires}, $DEFAULT_EXPIRATION);
 283     $to->{times}{expires}                   = defined $from->{expires_enabled}
 284                                                 ? boolean($from->{expires_enabled})
 285                                                 : boolean($to->{times}{expiry_time} <= gmtime);
 286     $to->{times}{creation_time}             = _decode_datetime($from->{created});
 287     $to->{times}{last_modification_time}    = _decode_datetime($from->{modified});
 288     $to->{times}{location_changed}          = _decode_datetime($from->{location_changed});
 289
 290     $to->{auto_type}{data_transfer_obfuscation} = $from->{auto_type_munge} || false;
 291     $to->{auto_type}{enabled}                   = boolean($from->{auto_type_enabled} // 1);
 292
 293     my $comment = $from->{comment};
 294     my @auto_type = is_arrayref($from->{auto_type}) ? @{$from->{auto_type}} : ();
 295
 296     if (!@auto_type && nonempty $from->{auto_type} && nonempty $from->{auto_type_window}
 297         && !is_hashref($from->{auto_type})) {
 298         @auto_type = ({window => $from->{auto_type_window}, keys => $from->{auto_type}});
 299     }
 300     if (nonempty $comment) {
 301         my @AT;
 302         my %atw = my @atw = $comment =~ m{ ^Auto-Type-Window((?:-?\d+)?): [\t ]* (.*?) [\t ]*$ }mxg;
 303         my %atk = my @atk = $comment =~ m{ ^Auto-Type((?:-?\d+)?): [\t ]* (.*?) [\t ]*$ }mxg;
 304         $comment =~ s{ ^Auto-Type(?:-Window)?(?:-?\d+)?: .* \n? }{}mxg;
 305         while (@atw) {
 306             my ($n, $w) = (shift(@atw), shift(@atw));
 307             push @AT, {window => $w, keys => exists($atk{$n}) ? $atk{$n} : $atk{''}};
 308         }
 309         while (@atk) {
 310             my ($n, $k) = (shift(@atk), shift(@atk));
 311             push @AT, {keys => $k, window => exists($atw{$n}) ? $atw{$n} : $atw{''}};
 312         }
 313         for (@AT) {
 314             $_->{'window'} //= '';
 315             $_->{'keys'} //= '';
 316         }
 317         my %uniq;
 318         @AT = grep {!$uniq{"$_->{'window'}\e$_->{'keys'}"}++} @AT;
 319         push @auto_type, @AT;
 320     }
 321     $to->{auto_type}{associations} = [
 322         map { +{window => $_->{window}, keystroke_sequence => $_->{keys}} } @auto_type,
 323     ];
 324
 325     $to->{strings}{Notes}{value}        = $comment;
 326     $to->{strings}{UserName}{value}     = $from->{username};
 327     $to->{strings}{Password}{value}     = $from->{password};
 328     $to->{strings}{URL}{value}          = $from->{url};
 329     $to->{strings}{Title}{value}        = $from->{title};
 330     $to->{strings}{Notes}{protect}      = true if defined $from->{protected}{comment};
 331     $to->{strings}{UserName}{protect}   = true if defined $from->{protected}{username};
 332     $to->{strings}{Password}{protect}   = true if $from->{protected}{password} // 1;
 333     $to->{strings}{URL}{protect}        = true if defined $from->{protected}{url};
 334     $to->{strings}{Title}{protect}      = true if defined $from->{protected}{title};
 335
 336     # other strings
 337     while (my ($key, $value) = each %{$from->{strings} || {}}) {
 338         $to->{strings}{$key} = {
 339             value => $value,
 340             $from->{protected}{$key} ? (protect => true) : (),
 341         };
 342     }
 343
 344     $to->{override_url}     = $from->{override_url};
 345     $to->{tags}             = $from->{tags} // '';
 346     $to->{icon_id}          = $from->{icon} // ICON_PASSWORD;
 347     $to->{uuid}             = _decode_uuid($from->{id});
 348     $to->{foreground_color} = $from->{foreground_color} // '';
 349     $to->{background_color} = $from->{background_color} // '';
 350     $to->{custom_icon_uuid} = $from->{custom_icon_uuid};
 351     $to->{history}          = [];
 352
 353     local $from->{binary} = {$from->{binary_name} => $from->{binary}}
 354         if nonempty $from->{binary} && nonempty $from->{binary_name} && !is_hashref($from->{binary});
 355     while (my ($key, $value) = each %{$from->{binary} || {}}) {
 356         $to->{binaries}{$key} = {value => $value};
 357     }
 358
 359     if (!$args{shallow}) {
 360         for my $entry (@{$from->{history} || []}) {
 361             my $new_entry = {};
 362             push @{$to->{entries}}, _convert_keepass_to_kdbx_entry($entry, $new_entry);
 363         }
 364     }
 365
 366     return $to;
 367 }
 368
 369 sub _decode_datetime {
 370     local $_ = shift // return shift // gmtime;
 371     return Time::Piece->strptime($_, '%Y-%m-%d %H:%M:%S');
 372 }
 373
 374 sub _decode_uuid {
 375     local $_ = shift // return;
 376     # Group IDs in KDB files are 32-bit integers
 377     return sprintf('%016x', $_) if length($_) != 16 && looks_like_number($_);
 378     return $_;
 379 }
 380
 381 sub _decode_tristate {
 382     local $_ = shift // return;
 383     return boolean($_);
 384 }
 385
 386 1;
 387
 388 __END__
 389
 390 =pod
 391
 392 =encoding UTF-8
 393
 394 =head1 NAME
 395
 396 File::KDBX::Loader::KDB - Read KDB files
 397
 398 =head1 VERSION
 399
 400 version 0.902
 401
 402 =head1 DESCRIPTION
 403
 404 Read older KDB (KeePass 1) files. This feature requires an additional module to be installed:
 405
 406 =over 4
 407
 408 =item *
 409
 410 L<File::KeePass>
 411
 412 =back
 413
 414 =head1 FUNCTIONS
 415
 416 =head2 convert_keepass_to_kdbx
 417
 418     $kdbx = convert_keepass_to_kdbx($keepass);
 419     $kdbx = convert_keepass_to_kdbx($keepass, $kdbx);
 420
 421 Convert a L<File::KeePass> to a L<File::KDBX>.
 422
 423 =head1 BUGS
 424
 425 Please report any bugs or feature requests on the bugtracker website
 426 L<https://github.com/chazmcgarvey/File-KDBX/issues>
 427
 428 When submitting a bug or request, please include a test-file or a
 429 patch to an existing test-file that illustrates the bug or desired
 430 feature.
 431
 432 =head1 AUTHOR
 433
 434 Charles McGarvey <ccm@cpan.org>
 435
 436 =head1 COPYRIGHT AND LICENSE
 437
 438 This software is copyright (c) 2022 by Charles McGarvey.
 439
 440 This is free software; you can redistribute it and/or modify it under
 441 the same terms as the Perl 5 programming language system itself.
 442
 443 =cut