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