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