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