Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Dumper/XML.pm

   1 package File::KDBX::Dumper::XML;
   2 # ABSTRACT: Dump unencrypted XML KeePass files
   3
   4 use warnings;
   5 use strict;
   6
   7 use Crypt::Digest qw(digest_data);
   8 use Crypt::Misc 0.029 qw(encode_b64);
   9 use Encode qw(encode);
  10 use File::KDBX::Constants qw(:version :time);
  11 use File::KDBX::Error;
  12 use File::KDBX::Util qw(:class :int erase_scoped gzip snakify);
  13 use IO::Handle;
  14 use Scalar::Util qw(blessed isdual looks_like_number);
  15 use Time::Piece 1.33;
  16 use XML::LibXML;
  17 use boolean;
  18 use namespace::clean;
  19
  20 extends 'File::KDBX::Dumper';
  21
  22 our $VERSION = '0.903'; # VERSION
  23
  24
  25 has allow_protection => 1;
  26 has binaries => sub { $_[0]->kdbx->version < KDBX_VERSION_4_0 };
  27 has 'compress_binaries';
  28 has 'compress_datetimes';
  29
  30 sub header_hash { $_[0]->{header_hash} }
  31
  32 sub _binaries_written { $_[0]->{_binaries_written} //= {} }
  33
  34 sub _random_stream { $_[0]->{random_stream} //= $_[0]->kdbx->random_stream }
  35
  36 sub _dump {
  37     my $self = shift;
  38     my $fh   = shift;
  39
  40     $self->_write_inner_body($fh, $self->header_hash);
  41 }
  42
  43 sub _write_inner_body {
  44     my $self = shift;
  45     my $fh   = shift;
  46     my $header_hash = shift;
  47
  48     my $dom = XML::LibXML::Document->new('1.0', 'UTF-8');
  49     $dom->setStandalone(1);
  50
  51     my $doc = XML::LibXML::Element->new('KeePassFile');
  52     $dom->setDocumentElement($doc);
  53
  54     my $meta = XML::LibXML::Element->new('Meta');
  55     $doc->appendChild($meta);
  56     $self->_write_xml_meta($meta, $header_hash);
  57
  58     my $root = XML::LibXML::Element->new('Root');
  59     $doc->appendChild($root);
  60     $self->_write_xml_root($root);
  61
  62     $dom->toFH($fh, 1);
  63 }
  64
  65 sub _write_xml_meta {
  66     my $self = shift;
  67     my $node = shift;
  68     my $header_hash = shift;
  69
  70     my $meta = $self->kdbx->meta;
  71     local $meta->{generator}    = $self->kdbx->user_agent_string // __PACKAGE__;
  72     local $meta->{header_hash}  = $header_hash;
  73
  74     $self->_write_xml_from_pairs($node, $meta,
  75         Generator                   => 'text',
  76         $self->kdbx->version < KDBX_VERSION_4_0 && defined $meta->{header_hash} ? (
  77             HeaderHash              => 'binary',
  78         ) : (),
  79         DatabaseName                => 'text',
  80         DatabaseNameChanged         => 'datetime',
  81         DatabaseDescription         => 'text',
  82         DatabaseDescriptionChanged  => 'datetime',
  83         DefaultUserName             => 'text',
  84         DefaultUserNameChanged      => 'datetime',
  85         MaintenanceHistoryDays      => 'number',
  86         Color                       => 'text',
  87         MasterKeyChanged            => 'datetime',
  88         MasterKeyChangeRec          => 'number',
  89         MasterKeyChangeForce        => 'number',
  90         MemoryProtection            => \&_write_xml_memory_protection,
  91         CustomIcons                 => \&_write_xml_custom_icons,
  92         RecycleBinEnabled           => 'bool',
  93         RecycleBinUUID              => 'uuid',
  94         RecycleBinChanged           => 'datetime',
  95         EntryTemplatesGroup         => 'uuid',
  96         EntryTemplatesGroupChanged  => 'datetime',
  97         LastSelectedGroup           => 'uuid',
  98         LastTopVisibleGroup         => 'uuid',
  99         HistoryMaxItems             => 'number',
 100         HistoryMaxSize              => 'number',
 101         $self->kdbx->version >= KDBX_VERSION_4_0 ? (
 102             SettingsChanged         => 'datetime',
 103         ) : (),
 104         $self->kdbx->version < KDBX_VERSION_4_0 || $self->binaries ? (
 105             Binaries                => \&_write_xml_binaries,
 106         ) : (),
 107         CustomData                  => \&_write_xml_custom_data,
 108     );
 109 }
 110
 111 sub _write_xml_memory_protection {
 112     my $self = shift;
 113     my $node = shift;
 114
 115     my $memory_protection = $self->kdbx->meta->{memory_protection};
 116
 117     $self->_write_xml_from_pairs($node, $memory_protection,
 118         ProtectTitle            => 'bool',
 119         ProtectUserName         => 'bool',
 120         ProtectPassword         => 'bool',
 121         ProtectURL              => 'bool',
 122         ProtectNotes            => 'bool',
 123         # AutoEnableVisualHiding  => 'bool',
 124     );
 125 }
 126
 127 sub _write_xml_binaries {
 128     my $self = shift;
 129     my $node = shift;
 130
 131     my $kdbx = $self->kdbx;
 132
 133     my $new_ref = keys %{$self->_binaries_written};
 134     my $written = $self->_binaries_written;
 135
 136     my $entries = $kdbx->entries(history => 1);
 137     while (my $entry = $entries->next) {
 138         for my $key (keys %{$entry->binaries}) {
 139             my $binary = $entry->binaries->{$key};
 140             if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
 141                 $binary = $kdbx->binaries->{$binary->{ref}};
 142             }
 143
 144             if (!defined $binary->{value}) {
 145                 alert "Skipping binary which has no value: $key", key => $key;
 146                 next;
 147             }
 148
 149             my $hash = digest_data('SHA256', $binary->{value});
 150             if (defined $written->{$hash}) {
 151                 # nothing
 152             }
 153             else {
 154                 my $binary_node = $node->addNewChild(undef, 'Binary');
 155                 $binary_node->setAttribute('ID', _encode_text($new_ref));
 156                 $binary_node->setAttribute('Protected', _encode_bool(true)) if $binary->{protect};
 157                 $self->_write_xml_compressed_content($binary_node, \$binary->{value}, $binary->{protect});
 158                 $written->{$hash} = $new_ref++;
 159             }
 160         }
 161     }
 162 }
 163
 164 sub _write_xml_compressed_content {
 165     my $self = shift;
 166     my $node = shift;
 167     my $value = shift;
 168     my $protect = shift;
 169
 170     my @cleanup;
 171
 172     my $encoded;
 173     if (utf8::is_utf8($$value)) {
 174         $encoded = encode('UTF-8', $$value);
 175         push @cleanup, erase_scoped $encoded;
 176         $value = \$encoded;
 177     }
 178
 179     my $should_compress = $self->compress_binaries;
 180     my $try_compress = $should_compress || !defined $should_compress;
 181
 182     my $compressed;
 183     if ($try_compress) {
 184         $compressed = gzip($$value);
 185         push @cleanup, erase_scoped $compressed;
 186
 187         if ($should_compress || length($compressed) < length($$value)) {
 188             $value = \$compressed;
 189             $node->setAttribute('Compressed', _encode_bool(true));
 190         }
 191     }
 192
 193     my $encrypted;
 194     if ($protect) {
 195         $encrypted = $self->_random_stream->crypt($$value);
 196         push @cleanup, erase_scoped $encrypted;
 197         $value = \$encrypted;
 198     }
 199
 200     $node->appendText(_encode_binary($$value));
 201 }
 202
 203 sub _write_xml_custom_icons {
 204     my $self = shift;
 205     my $node = shift;
 206
 207     my $custom_icons = $self->kdbx->custom_icons;
 208
 209     for my $icon (@$custom_icons) {
 210         $icon->{uuid} && $icon->{data} or next;
 211         my $icon_node = $node->addNewChild(undef, 'Icon');
 212
 213         $self->_write_xml_from_pairs($icon_node, $icon,
 214             UUID                        => 'uuid',
 215             Data                        => 'binary',
 216             KDBX_VERSION_4_1 <= $self->kdbx->version ? (
 217                 Name                    => 'text',
 218                 LastModificationTime    => 'datetime',
 219             ) : (),
 220         );
 221     }
 222 }
 223
 224 sub _write_xml_custom_data {
 225     my $self = shift;
 226     my $node = shift;
 227     my $custom_data = shift || {};
 228
 229     for my $key (sort keys %$custom_data) {
 230         my $item = $custom_data->{$key};
 231         my $item_node = $node->addNewChild(undef, 'Item');
 232
 233         local $item->{key} = $key if !defined $item->{key};
 234
 235         $self->_write_xml_from_pairs($item_node, $item,
 236             Key     => 'text',
 237             Value   => 'text',
 238             KDBX_VERSION_4_1 <= $self->kdbx->version ? (
 239                 LastModificationTime    => 'datetime',
 240             ) : (),
 241         );
 242     }
 243 }
 244
 245 sub _write_xml_root {
 246     my $self = shift;
 247     my $node = shift;
 248     my $kdbx = $self->kdbx;
 249
 250     my $guard = $kdbx->unlock_scoped;
 251
 252     if (my $group = $kdbx->root) {
 253         my $group_node = $node->addNewChild(undef, 'Group');
 254         $self->_write_xml_group($group_node, $group->_committed);
 255     }
 256
 257     undef $guard;   # re-lock if needed, as early as possible
 258
 259     my $deleted_objects_node = $node->addNewChild(undef, 'DeletedObjects');
 260     $self->_write_xml_deleted_objects($deleted_objects_node);
 261 }
 262
 263 sub _write_xml_group {
 264     my $self = shift;
 265     my $node = shift;
 266     my $group = shift;
 267
 268     $self->_write_xml_from_pairs($node, $group,
 269         UUID                    => 'uuid',
 270         Name                    => 'text',
 271         Notes                   => 'text',
 272         KDBX_VERSION_4_1 <= $self->kdbx->version ? (
 273             Tags                => 'text',
 274         ) : (),
 275         IconID                  => 'number',
 276         defined $group->{custom_icon_uuid} ? (
 277             CustomIconUUID      => 'uuid',
 278         ) : (),
 279         Times                   => \&_write_xml_times,
 280         IsExpanded              => 'bool',
 281         DefaultAutoTypeSequence => 'text',
 282         EnableAutoType          => 'tristate',
 283         EnableSearching         => 'tristate',
 284         LastTopVisibleEntry     => 'uuid',
 285         KDBX_VERSION_4_0 <= $self->kdbx->version ? (
 286             CustomData          => \&_write_xml_custom_data,
 287         ) : (),
 288         KDBX_VERSION_4_1 <= $self->kdbx->version ? (
 289             PreviousParentGroup => 'uuid',
 290         ) : (),
 291     );
 292
 293     for my $entry (@{$group->entries}) {
 294         my $entry_node = $node->addNewChild(undef, 'Entry');
 295         $self->_write_xml_entry($entry_node, $entry->_committed);
 296     }
 297
 298     for my $group (@{$group->groups}) {
 299         my $group_node = $node->addNewChild(undef, 'Group');
 300         $self->_write_xml_group($group_node, $group->_committed);
 301     }
 302 }
 303
 304 sub _write_xml_entry {
 305     my $self        = shift;
 306     my $node        = shift;
 307     my $entry       = shift;
 308     my $in_history  = shift;
 309
 310     $self->_write_xml_from_pairs($node, $entry,
 311         UUID                    => 'uuid',
 312         IconID                  => 'number',
 313         defined $entry->{custom_icon_uuid} ? (
 314             CustomIconUUID      => 'uuid',
 315         ) : (),
 316         ForegroundColor         => 'text',
 317         BackgroundColor         => 'text',
 318         OverrideURL             => 'text',
 319         Tags                    => 'text',
 320         Times                   => \&_write_xml_times,
 321         KDBX_VERSION_4_1 <= $self->kdbx->version ? (
 322             QualityCheck        => 'bool',
 323             PreviousParentGroup => 'uuid',
 324         ) : (),
 325     );
 326
 327     for my $key (sort keys %{$entry->{strings} || {}}) {
 328         my $string = $entry->{strings}{$key};
 329         my $string_node = $node->addNewChild(undef, 'String');
 330         local $string->{key} = $string->{key} // $key;
 331         $self->_write_xml_entry_string($string_node, $string);
 332     }
 333
 334     my $kdbx = $self->kdbx;
 335     my $new_ref = keys %{$self->_binaries_written};
 336     my $written = $self->_binaries_written;
 337
 338     for my $key (sort keys %{$entry->{binaries} || {}}) {
 339         my $binary = $entry->binaries->{$key};
 340         if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
 341             $binary = $kdbx->binaries->{$binary->{ref}};
 342         }
 343
 344         if (!defined $binary->{value}) {
 345             alert "Skipping binary which has no value: $key", key => $key;
 346             next;
 347         }
 348
 349         my $binary_node = $node->addNewChild(undef, 'Binary');
 350         $binary_node->addNewChild(undef, 'Key')->appendText(_encode_text($key));
 351             my $value_node = $binary_node->addNewChild(undef, 'Value');
 352
 353         my $hash = digest_data('SHA256', $binary->{value});
 354         if (defined $written->{$hash}) {
 355             # write reference
 356             $value_node->setAttribute('Ref', _encode_text($written->{$hash}));
 357         }
 358         else {
 359             # write actual binary
 360             $value_node->setAttribute('Protected', _encode_bool(true)) if $binary->{protect};
 361             $self->_write_xml_compressed_content($value_node, \$binary->{value}, $binary->{protect});
 362             $written->{$hash} = $new_ref++;
 363         }
 364     }
 365
 366     $self->_write_xml_from_pairs($node, $entry,
 367         AutoType => \&_write_xml_entry_auto_type,
 368     );
 369
 370     $self->_write_xml_from_pairs($node, $entry,
 371         KDBX_VERSION_4_0 <= $self->kdbx->version ? (
 372             CustomData => \&_write_xml_custom_data,
 373         ) : (),
 374     );
 375
 376     if (!$in_history) {
 377         if (my @history = @{$entry->history}) {
 378             my $history_node = $node->addNewChild(undef, 'History');
 379             for my $historical (@history) {
 380                 my $historical_node = $history_node->addNewChild(undef, 'Entry');
 381                 $self->_write_xml_entry($historical_node, $historical->_committed, 1);
 382             }
 383         }
 384     }
 385 }
 386
 387 sub _write_xml_entry_auto_type {
 388     my $self = shift;
 389     my $node = shift;
 390     my $autotype = shift;
 391
 392     $self->_write_xml_from_pairs($node, $autotype,
 393         Enabled                 => 'bool',
 394         DataTransferObfuscation => 'number',
 395         DefaultSequence         => 'text',
 396     );
 397
 398     for my $association (@{$autotype->{associations} || []}) {
 399         my $association_node = $node->addNewChild(undef, 'Association');
 400         $self->_write_xml_from_pairs($association_node, $association,
 401             Window              => 'text',
 402             KeystrokeSequence   => 'text',
 403         );
 404     }
 405 }
 406
 407 sub _write_xml_times {
 408     my $self = shift;
 409     my $node = shift;
 410     my $times = shift;
 411
 412     $self->_write_xml_from_pairs($node, $times,
 413         LastModificationTime    => 'datetime',
 414         CreationTime            => 'datetime',
 415         LastAccessTime          => 'datetime',
 416         ExpiryTime              => 'datetime',
 417         Expires                 => 'bool',
 418         UsageCount              => 'number',
 419         LocationChanged         => 'datetime',
 420     );
 421 }
 422
 423 sub _write_xml_entry_string {
 424     my $self = shift;
 425     my $node = shift;
 426     my $string = shift;
 427
 428     my @cleanup;
 429
 430     my $kdbx = $self->kdbx;
 431     my $key = $string->{key};
 432
 433     $node->addNewChild(undef, 'Key')->appendText(_encode_text($key));
 434     my $value_node = $node->addNewChild(undef, 'Value');
 435
 436     my $value = $string->{value} || '';
 437
 438     my $memory_protection = $kdbx->meta->{memory_protection};
 439     my $memprot_key = 'protect_' . snakify($key);
 440     my $protect = $string->{protect} || $memory_protection->{$memprot_key};
 441
 442     if ($protect) {
 443         if ($self->allow_protection) {
 444             my $encoded;
 445             if (utf8::is_utf8($value)) {
 446                 $encoded = encode('UTF-8', $value);
 447                 push @cleanup, erase_scoped $encoded;
 448                 $value = $encoded;
 449             }
 450
 451             $value_node->setAttribute('Protected', _encode_bool(true));
 452             $value = _encode_binary($self->_random_stream->crypt(\$value));
 453         }
 454         else {
 455             $value_node->setAttribute('ProtectInMemory', _encode_bool(true));
 456             $value = _encode_text($value);
 457         }
 458     }
 459     else {
 460         $value = _encode_text($value);
 461     }
 462
 463     $value_node->appendText($value) if defined $value;
 464 }
 465
 466 sub _write_xml_deleted_objects {
 467     my $self = shift;
 468     my $node = shift;
 469
 470     my $objects = $self->kdbx->deleted_objects;
 471
 472     for my $uuid (sort keys %{$objects || {}}) {
 473         my $object = $objects->{$uuid};
 474         local $object->{uuid} = $uuid;
 475         my $object_node = $node->addNewChild(undef, 'DeletedObject');
 476         $self->_write_xml_from_pairs($object_node, $object,
 477             UUID            => 'uuid',
 478             DeletionTime    => 'datetime',
 479         );
 480     }
 481 }
 482
 483 ##############################################################################
 484
 485 sub _write_xml_from_pairs {
 486     my $self = shift;
 487     my $node = shift;
 488     my $hash = shift;
 489     my @spec = @_;
 490
 491     while (@spec) {
 492         my ($name, $type) = splice @spec, 0, 2;
 493         my $key = snakify($name);
 494
 495         if (ref $type eq 'CODE') {
 496             my $child_node = $node->addNewChild(undef, $name);
 497             $self->$type($child_node, $hash->{$key});
 498         }
 499         else {
 500             next if !exists $hash->{$key};
 501             my $child_node = $node->addNewChild(undef, $name);
 502             $type = 'datetime_binary' if $type eq 'datetime' && $self->compress_datetimes;
 503             $child_node->appendText(_encode_primitive($hash->{$key}, $type));
 504         }
 505     }
 506 }
 507
 508 ##############################################################################
 509
 510 sub _encode_primitive { goto &{__PACKAGE__."::_encode_$_[1]"} }
 511
 512 sub _encode_binary {
 513     return '' if !defined $_[0] || (ref $_[0] && !defined $$_[0]);
 514     return encode_b64(ref $_[0] ? $$_[0] : $_[0]);
 515 }
 516
 517 sub _encode_bool {
 518     local $_ = shift;
 519     return $_ ? 'True' : 'False';
 520 }
 521
 522 sub _encode_datetime {
 523     local $_ = shift;
 524     return $_->strftime('%Y-%m-%dT%H:%M:%SZ');
 525 }
 526
 527 sub _encode_datetime_binary {
 528     local $_ = shift;
 529     my $seconds_since_ad1 = $_ + TIME_SECONDS_AD1_TO_UNIX_EPOCH;
 530     my $buf = pack_Ql($seconds_since_ad1->epoch);
 531     return eval { encode_b64($buf) };
 532 }
 533
 534 sub _encode_tristate {
 535     local $_ = shift // return 'null';
 536     return $_ ? 'True' : 'False';
 537 }
 538
 539 sub _encode_number {
 540     local $_ = shift // return;
 541     looks_like_number($_) || isdual($_) or throw 'Expected number', text => $_;
 542     return _encode_text($_+0);
 543 }
 544
 545 sub _encode_text {
 546     return '' if !defined $_[0];
 547     return $_[0];
 548 }
 549
 550 sub _encode_uuid { _encode_binary(@_) }
 551
 552 1;
 553
 554 __END__
 555
 556 =pod
 557
 558 =encoding UTF-8
 559
 560 =head1 NAME
 561
 562 File::KDBX::Dumper::XML - Dump unencrypted XML KeePass files
 563
 564 =head1 VERSION
 565
 566 version 0.903
 567
 568 =head1 ATTRIBUTES
 569
 570 =head2 allow_protection
 571
 572     $bool = $dumper->allow_protection;
 573
 574 Get whether or not protected strings and binaries should be written in an encrypted stream. Default: C<TRUE>
 575
 576 =head2 binaries
 577
 578     $bool = $dumper->binaries;
 579
 580 Get whether or not binaries within the database should be written. Default: C<TRUE>
 581
 582 =head2 compress_binaries
 583
 584     $tristate = $dumper->compress_binaries;
 585
 586 Get whether or not to compress binaries. Possible values:
 587
 588 =over 4
 589
 590 =item *
 591
 592 C<TRUE> - Always compress binaries
 593
 594 =item *
 595
 596 C<FALSE> - Never compress binaries
 597
 598 =item *
 599
 600 C<undef> - Compress binaries if it results in smaller database sizes (default)
 601
 602 =back
 603
 604 =head2 compress_datetimes
 605
 606     $bool = $dumper->compress_datetimes;
 607
 608 Get whether or not to write compressed datetimes. Datetimes are traditionally written in the human-readable
 609 string format of C<1970-01-01T00:00:00Z>, but they can also be written in a compressed form to save some
 610 bytes. The default is to write compressed datetimes if the KDBX file version is 4+, otherwise use the
 611 human-readable format.
 612
 613 =head2 header_hash
 614
 615     $octets = $dumper->header_hash;
 616
 617 Get the value to be written as the B<HeaderHash> in the B<Meta> section. This is the way KDBX3 files validate
 618 the authenticity of header data. This is unnecessary and should not be used with KDBX4 files because that
 619 format uses HMAC-SHA256 to detect tampering.
 620
 621 L<File::KDBX::Dumper::V3> automatically calculates the header hash an provides it to this module, and plain
 622 XML files which don't have a KDBX wrapper don't have headers and so should not have a header hash. Therefore
 623 there is probably never any reason to set this manually.
 624
 625 =head1 BUGS
 626
 627 Please report any bugs or feature requests on the bugtracker website
 628 L<https://github.com/chazmcgarvey/File-KDBX/issues>
 629
 630 When submitting a bug or request, please include a test-file or a
 631 patch to an existing test-file that illustrates the bug or desired
 632 feature.
 633
 634 =head1 AUTHOR
 635
 636 Charles McGarvey <ccm@cpan.org>
 637
 638 =head1 COPYRIGHT AND LICENSE
 639
 640 This software is copyright (c) 2022 by Charles McGarvey.
 641
 642 This is free software; you can redistribute it and/or modify it under
 643 the same terms as the Perl 5 programming language system itself.
 644
 645 =cut