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

   1 package File::KDBX::Loader::XML;
   2 # ABSTRACT: Load unencrypted XML KeePass files
   3
   4 use warnings;
   5 use strict;
   6
   7 use Crypt::Misc 0.029 qw(decode_b64);
   8 use Encode qw(decode);
   9 use File::KDBX::Constants qw(:version :time);
  10 use File::KDBX::Error;
  11 use File::KDBX::Safe;
  12 use File::KDBX::Util qw(:text assert_64bit gunzip erase_scoped);
  13 use Scalar::Util qw(looks_like_number);
  14 use Time::Piece;
  15 use XML::LibXML::Reader;
  16 use boolean;
  17 use namespace::clean;
  18
  19 use parent 'File::KDBX::Loader';
  20
  21 our $VERSION = '999.999'; # VERSION
  22
  23 sub _reader { $_[0]->{_reader} }
  24
  25 sub _binaries { $_[0]->{binaries} //= {} }
  26
  27 sub _safe { $_[0]->{safe} //= File::KDBX::Safe->new(cipher => $_[0]->kdbx->random_stream) }
  28
  29 sub _read {
  30     my $self = shift;
  31     my $fh   = shift;
  32
  33     $self->_read_inner_body($fh);
  34 }
  35
  36 sub _read_inner_body {
  37     my $self = shift;
  38     my $fh   = shift;
  39
  40     my $reader = $self->{_reader} = XML::LibXML::Reader->new(IO => $fh);
  41
  42     delete $self->{safe};
  43     my $root_done;
  44
  45     my $pattern = XML::LibXML::Pattern->new('/KeePassFile/Meta|/KeePassFile/Root');
  46     while ($reader->nextPatternMatch($pattern) == 1) {
  47         next if $reader->nodeType != XML_READER_TYPE_ELEMENT;
  48         my $name = $reader->localName;
  49         if ($name eq 'Meta') {
  50             $self->_read_xml_meta;
  51         }
  52         elsif ($name eq 'Root') {
  53             if ($root_done) {
  54                 alert 'Ignoring extra Root element in KeePass XML file', line => $reader->lineNumber;
  55                 next;
  56             }
  57             $self->_read_xml_root;
  58             $root_done = 1;
  59         }
  60     }
  61
  62     if ($reader->readState == XML_READER_ERROR) {
  63         throw 'Failed to parse KeePass XML';
  64     }
  65
  66     $self->kdbx->_safe($self->_safe) if $self->{safe};
  67
  68     $self->_resolve_binary_refs;
  69 }
  70
  71 sub _read_xml_meta {
  72     my $self = shift;
  73
  74     $self->_read_xml_element($self->kdbx->meta,
  75         Generator                   => 'text',
  76         HeaderHash                  => 'binary',
  77         DatabaseName                => 'text',
  78         DatabaseNameChanged         => 'datetime',
  79         DatabaseDescription         => 'text',
  80         DatabaseDescriptionChanged  => 'datetime',
  81         DefaultUserName             => 'text',
  82         DefaultUserNameChanged      => 'datetime',
  83         MaintenanceHistoryDays      => 'number',
  84         Color                       => 'text',
  85         MasterKeyChanged            => 'datetime',
  86         MasterKeyChangeRec          => 'number',
  87         MasterKeyChangeForce        => 'number',
  88         MemoryProtection            => \&_read_xml_memory_protection,
  89         CustomIcons                 => \&_read_xml_custom_icons,
  90         RecycleBinEnabled           => 'bool',
  91         RecycleBinUUID              => 'uuid',
  92         RecycleBinChanged           => 'datetime',
  93         EntryTemplatesGroup         => 'uuid',
  94         EntryTemplatesGroupChanged  => 'datetime',
  95         LastSelectedGroup           => 'uuid',
  96         LastTopVisibleGroup         => 'uuid',
  97         HistoryMaxItems             => 'number',
  98         HistoryMaxSize              => 'number',
  99         SettingsChanged             => 'datetime',
 100         Binaries                    => \&_read_xml_binaries,
 101         CustomData                  => \&_read_xml_custom_data,
 102     );
 103 }
 104
 105 sub _read_xml_memory_protection {
 106     my $self = shift;
 107     my $meta = shift // $self->kdbx->meta;
 108
 109     return $self->_read_xml_element(
 110         ProtectTitle            => 'bool',
 111         ProtectUserName         => 'bool',
 112         ProtectPassword         => 'bool',
 113         ProtectURL              => 'bool',
 114         ProtectNotes            => 'bool',
 115         AutoEnableVisualHiding  => 'bool',
 116     );
 117 }
 118
 119 sub _read_xml_binaries {
 120     my $self = shift;
 121     my $kdbx = $self->kdbx;
 122
 123     my $binaries = $self->_read_xml_element(
 124         Binary  => sub {
 125             my $self = shift;
 126             my $id          = $self->_read_xml_attribute('ID');
 127             my $compressed  = $self->_read_xml_attribute('Compressed', 'bool', false);
 128             my $protected   = $self->_read_xml_attribute('Protected', 'bool', false);
 129             my $data        = $self->_read_xml_content('binary');
 130
 131             my $binary = {
 132                 value   => $data,
 133                 $protected ? (protect => true) : (),
 134             };
 135
 136             if ($protected) {
 137                 # if compressed, decompress later when the safe is unlocked
 138                 $self->_safe->add_protected($compressed ? \&gunzip : (), $binary);
 139             }
 140             elsif ($compressed) {
 141                 $binary->{value} = gunzip($data);
 142             }
 143
 144             $id => $binary;
 145         },
 146     );
 147
 148     $kdbx->binaries({%{$kdbx->binaries}, %$binaries});
 149     return (); # do not add to meta
 150 }
 151
 152 sub _read_xml_custom_data {
 153     my $self = shift;
 154
 155     return $self->_read_xml_element(
 156         Item    => sub {
 157             my $self = shift;
 158             my $item = $self->_read_xml_element(
 159                 Key                     => 'text',
 160                 Value                   => 'text',
 161                 LastModificationTime    => 'datetime',  # KDBX4.1
 162             );
 163             $item->{key} => $item;
 164         },
 165     );
 166 }
 167
 168 sub _read_xml_custom_icons {
 169     my $self = shift;
 170
 171     return $self->_read_xml_element(
 172         Icon    => sub {
 173             my $self = shift;
 174             my $icon = $self->_read_xml_element(
 175                 UUID                    => 'uuid',
 176                 Data                    => 'binary',
 177                 Name                    => 'text',      # KDBX4.1
 178                 LastModificationTime    => 'datetime',  # KDBX4.1
 179             );
 180             $icon->{uuid} => $icon;
 181         },
 182     );
 183 }
 184
 185 sub _read_xml_root {
 186     my $self = shift;
 187     my $kdbx = $self->kdbx;
 188
 189     my $root = $self->_read_xml_element(
 190         Group           => \&_read_xml_group,
 191         DeletedObjects  => \&_read_xml_deleted_objects,
 192     );
 193
 194     $kdbx->deleted_objects($root->{deleted_objects});
 195     $kdbx->root($root->{group}) if $root->{group};
 196 }
 197
 198 sub _read_xml_group {
 199     my $self = shift;
 200
 201     return $self->_read_xml_element({entries => [], groups => []},
 202         UUID                    => 'uuid',
 203         Name                    => 'text',
 204         Notes                   => 'text',
 205         Tags                    => 'text',  # KDBX4.1
 206         IconID                  => 'number',
 207         CustomIconUUID          => 'uuid',
 208         Times                   => \&_read_xml_times,
 209         IsExpanded              => 'bool',
 210         DefaultAutoTypeSequence => 'text',
 211         EnableAutoType          => 'tristate',
 212         EnableSearching         => 'tristate',
 213         LastTopVisibleEntry     => 'uuid',
 214         CustomData              => \&_read_xml_custom_data, # KDBX4
 215         PreviousParentGroup     => 'uuid',  # KDBX4.1
 216         Entry                   => [entries => \&_read_xml_entry],
 217         Group                   => [groups  => \&_read_xml_group],
 218     );
 219 }
 220
 221 sub _read_xml_entry {
 222     my $self = shift;
 223
 224     my $entry = $self->_read_xml_element({strings => [], binaries => []},
 225         UUID                => 'uuid',
 226         IconID              => 'number',
 227         CustomIconUUID      => 'uuid',
 228         ForegroundColor     => 'text',
 229         BackgroundColor     => 'text',
 230         OverrideURL         => 'text',
 231         Tags                => 'text',
 232         Times               => \&_read_xml_times,
 233         AutoType            => \&_read_xml_entry_auto_type,
 234         PreviousParentGroup => 'uuid',  # KDBX4.1
 235         QualityCheck        => 'bool',  # KDBX4.1
 236         String              => [strings  => \&_read_xml_entry_string],
 237         Binary              => [binaries => \&_read_xml_entry_binary],
 238         CustomData          => \&_read_xml_custom_data, # KDBX4
 239         History             => sub {
 240             my $self = shift;
 241             return $self->_read_xml_element([],
 242                 Entry   => \&_read_xml_entry,
 243             );
 244         },
 245     );
 246
 247     my %strings;
 248     for my $string (@{$entry->{strings} || []}) {
 249         $strings{$string->{key}} = $string->{value};
 250     }
 251     $entry->{strings} = \%strings;
 252
 253     my %binaries;
 254     for my $binary (@{$entry->{binaries} || []}) {
 255         $binaries{$binary->{key}} = $binary->{value};
 256     }
 257     $entry->{binaries} = \%binaries;
 258
 259     return $entry;
 260 }
 261
 262 sub _read_xml_times {
 263     my $self = shift;
 264
 265     return $self->_read_xml_element(
 266         LastModificationTime    => 'datetime',
 267         CreationTime            => 'datetime',
 268         LastAccessTime          => 'datetime',
 269         ExpiryTime              => 'datetime',
 270         Expires                 => 'bool',
 271         UsageCount              => 'number',
 272         LocationChanged         => 'datetime',
 273     );
 274 }
 275
 276 sub _read_xml_entry_string {
 277     my $self = shift;
 278
 279     return $self->_read_xml_element(
 280         Key     => 'text',
 281         Value   => sub {
 282             my $self = shift;
 283
 284             my $protected           = $self->_read_xml_attribute('Protected', 'bool', false);
 285             my $protect_in_memory   = $self->_read_xml_attribute('ProtectInMemory', 'bool', false);
 286             my $protect             = $protected || $protect_in_memory;
 287
 288             my $val = $self->_read_xml_content($protected ? 'binary' : 'text');
 289
 290             my $string = {
 291                 value   => $val,
 292                 $protect ? (protect => true) : (),
 293             };
 294
 295             $self->_safe->add_protected(sub { decode('UTF-8', $_[0]) }, $string) if $protected;
 296
 297             $string;
 298         },
 299     );
 300 }
 301
 302 sub _read_xml_entry_binary {
 303     my $self = shift;
 304
 305     return $self->_read_xml_element(
 306         Key     => 'text',
 307         Value   => sub {
 308             my $self = shift;
 309
 310             my $ref = $self->_read_xml_attribute('Ref');
 311             my $compressed  = $self->_read_xml_attribute('Compressed', 'bool', false);
 312             my $protected = $self->_read_xml_attribute('Protected', 'bool', false);
 313             my $binary = {};
 314
 315             if (defined $ref) {
 316                 $binary->{ref} = $ref;
 317             }
 318             else {
 319                 $binary->{value} = $self->_read_xml_content('binary');
 320                 $binary->{protect} = true if $protected;
 321
 322                 if ($protected) {
 323                     # if compressed, decompress later when the safe is unlocked
 324                     $self->_safe->add_protected($compressed ? \&gunzip : (), $binary);
 325                 }
 326                 elsif ($compressed) {
 327                     $binary->{value} = gunzip($binary->{value});
 328                 }
 329             }
 330
 331             $binary;
 332         },
 333     );
 334 }
 335
 336 sub _read_xml_entry_auto_type {
 337     my $self = shift;
 338
 339     return $self->_read_xml_element({associations => []},
 340         Enabled                 => 'bool',
 341         DataTransferObfuscation => 'number',
 342         DefaultSequence         => 'text',
 343         Association             => [associations => sub {
 344             my $self = shift;
 345             return $self->_read_xml_element(
 346                 Window              => 'text',
 347                 KeystrokeSequence   => 'text',
 348             );
 349         }],
 350     );
 351 }
 352
 353 sub _read_xml_deleted_objects {
 354     my $self = shift;
 355
 356     return $self->_read_xml_element(
 357         DeletedObject   => sub {
 358             my $self = shift;
 359             my $object = $self->_read_xml_element(
 360                 UUID            => 'uuid',
 361                 DeletionTime    => 'datetime',
 362             );
 363             $object->{uuid} => $object;
 364         }
 365     );
 366 }
 367
 368 ##############################################################################
 369
 370 sub _resolve_binary_refs {
 371     my $self = shift;
 372     my $kdbx = $self->kdbx;
 373
 374     my $entries = $kdbx->all_entries(history => 1);
 375     my $pool = $kdbx->binaries;
 376
 377     for my $entry (@$entries) {
 378         while (my ($key, $binary) = each %{$entry->binaries}) {
 379             my $ref = $binary->{ref} // next;
 380             next if defined $binary->{value};
 381
 382             my $data = $pool->{$ref};
 383             if (!defined $data || !defined $data->{value}) {
 384                 alert "Found a reference to a missing binary: $key", key => $key, ref => $ref;
 385                 next;
 386             }
 387             $binary->{value} = $data->{value};
 388             $binary->{protect} = true if $data->{protect};
 389             delete $binary->{ref};
 390         }
 391     }
 392 }
 393
 394 ##############################################################################
 395
 396 sub _read_xml_element {
 397     my $self = shift;
 398     my $args = @_ % 2 == 1 ? shift : {};
 399     my %spec = @_;
 400
 401     my $reader = $self->_reader;
 402     my $path = $reader->nodePath;
 403     $path =~ s!\Q/text()\E$!!;
 404
 405     return $args if $reader->isEmptyElement;
 406
 407     my $store = ref $args eq 'CODE' ? $args
 408     : ref $args eq 'HASH' ? sub {
 409         my ($key, $val) = @_;
 410         if (ref $args->{$key} eq 'HASH') {
 411             $args->{$key}{$key} = $val;
 412         }
 413         elsif (ref $args->{$key} eq 'ARRAY') {
 414             push @{$args->{$key}}, $val;
 415         }
 416         else {
 417             exists $args->{$key}
 418                 and alert 'Overwriting value', node => $reader->nodePath, line => $reader->lineNumber;
 419             $args->{$key} = $val;
 420         }
 421     } : ref $args eq 'ARRAY' ? sub {
 422         my ($key, $val) = @_;
 423         push @$args, $val;
 424     } : sub {};
 425
 426     my $pattern = XML::LibXML::Pattern->new("${path}|${path}/*");
 427     while ($reader->nextPatternMatch($pattern) == 1) {
 428         last if $reader->nodePath eq $path && $reader->nodeType == XML_READER_TYPE_END_ELEMENT;
 429         next if $reader->nodeType != XML_READER_TYPE_ELEMENT;
 430
 431         my $name = $reader->localName;
 432         my $key  = snakify($name);
 433         my $type = $spec{$name};
 434         ($key, $type) = @$type if ref $type eq 'ARRAY';
 435
 436         if (!defined $type) {
 437             exists $spec{$name} or alert "Ignoring unknown element: $name",
 438                 node => $reader->nodePath,
 439                 line => $reader->lineNumber;
 440             next;
 441         }
 442
 443         if (ref $type eq 'CODE') {
 444             my @result = $self->$type($args, $reader->nodePath);
 445             if (@result == 2) {
 446                 $store->(@result);
 447             }
 448             elsif (@result == 1) {
 449                 $store->($key, @result);
 450             }
 451         }
 452         else {
 453             $store->($key, $self->_read_xml_content($type));
 454         }
 455     }
 456
 457     return $args;
 458 }
 459
 460 sub _read_xml_attribute {
 461     my $self = shift;
 462     my $name = shift;
 463     my $type = shift // 'text';
 464     my $default = shift;
 465     my $reader = $self->_reader;
 466
 467     return $default if !$reader->hasAttributes;
 468
 469     my $value = trim($reader->getAttribute($name));
 470     if (!defined $value) {
 471         # try again after reading in all the attributes
 472         $reader->moveToFirstAttribute;
 473         while ($self->_reader->readAttributeValue == 1) {}
 474         $reader->moveToElement;
 475
 476         $value = trim($reader->getAttribute($name));
 477     }
 478
 479     return $default if !defined $value;
 480
 481     my $decoded = eval { _decode_primitive($value, $type) };
 482     if (my $err = $@) {
 483         ref $err and $err->details(attribute => $name, node => $reader->nodePath, line => $reader->lineNumber);
 484         throw $err
 485     }
 486
 487     return $decoded;
 488 }
 489
 490 sub _read_xml_content {
 491     my $self = shift;
 492     my $type = shift;
 493     my $reader = $self->_reader;
 494
 495     $reader->read if !$reader->isEmptyElement;  # step into element
 496     return '' if !$reader->hasValue;
 497
 498     my $content = trim($reader->value);
 499
 500     my $decoded = eval { _decode_primitive($content, $type) };
 501     if (my $err = $@) {
 502         ref $err and $err->details(node => $reader->nodePath, line => $reader->lineNumber);
 503         throw $err
 504     }
 505
 506     return $decoded;
 507 }
 508
 509 ##############################################################################
 510
 511 sub _decode_primitive { goto &{__PACKAGE__."::_decode_$_[1]"} }
 512
 513 sub _decode_binary {
 514     local $_ = shift;
 515     return '' if !defined || (ref && !defined $$_);
 516     $_ = eval { decode_b64(ref $_ ? $$_ : $_) };
 517     my $err = $@;
 518     my $cleanup = erase_scoped $_;
 519     $err and throw 'Failed to parse binary', error => $err;
 520     return $_;
 521 }
 522
 523 sub _decode_bool {
 524     local $_ = shift;
 525     return true  if /^True$/i;
 526     return false if /^False$/i;
 527     return false if length($_) == 0;
 528     throw 'Expected boolean', text => $_;
 529 }
 530
 531 sub _decode_datetime {
 532     local $_ = shift;
 533
 534     if (/^[A-Za-z0-9\+\/\=]+$/) {
 535         my $binary = eval { decode_b64($_) };
 536         if (my $err = $@) {
 537             throw 'Failed to parse binary datetime', text => $_, error => $err;
 538         }
 539         throw $@ if $@;
 540         assert_64bit;
 541         $binary .= \0 x (8 - length($binary)) if length($binary) < 8;
 542         my ($seconds_since_ad1) = unpack('Q<', $binary);
 543         my $epoch = $seconds_since_ad1 - TIME_SECONDS_AD1_TO_UNIX_EPOCH;
 544         return Time::Piece->new($epoch);
 545     }
 546
 547
 548     my $dt = eval { Time::Piece->strptime($_, '%Y-%m-%dT%H:%M:%SZ') };
 549     if (my $err = $@) {
 550         throw 'Failed to parse datetime', text => $_, error => $err;
 551     }
 552     return $dt;
 553 }
 554
 555 sub _decode_tristate {
 556     local $_ = shift;
 557     return undef if /^null$/i;
 558     my $tristate = eval { _decode_bool($_) };
 559     $@ and throw 'Expected tristate', text => $_, error => $@;
 560     return $tristate;
 561 }
 562
 563 sub _decode_number {
 564     local $_ = shift;
 565     $_ = _decode_text($_);
 566     looks_like_number($_) or throw 'Expected number', text => $_;
 567     return $_+0;
 568 }
 569
 570 sub _decode_text {
 571     local $_ = shift;
 572     return '' if !defined;
 573     return $_;
 574 }
 575
 576 sub _decode_uuid {
 577     local $_ = shift;
 578     my $uuid = eval { _decode_binary($_) };
 579     $@ and throw 'Expected UUID', text => $_, error => $@;
 580     length($uuid) == 16 or throw 'Invalid UUID size', size => length($uuid);
 581     return $uuid;
 582 }
 583
 584 1;