Dogcows Code - chaz/p5-File-KDBX/blob - t/memory-protection.t

   1 #!/usr/bin/env perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use lib 't/lib';
   7 use TestCommon;
   8
   9 use Crypt::Digest qw(digest_data);
  10 use Crypt::PRNG qw(random_bytes);
  11 use Crypt::Misc qw(decode_b64);
  12 use File::KDBX::Key;
  13 use File::KDBX::Util qw(:erase :load);
  14 use File::KDBX;
  15 use IO::Handle;
  16 use List::Util qw(max);
  17 use POSIX ();
  18 use Scalar::Util qw(looks_like_number);
  19 use Scope::Guard;
  20 use Test::More 1.001004_001;
  21
  22 BEGIN {
  23     if (!$ENV{AUTHOR_TESTING}) {
  24         plan skip_all => 'AUTHOR_TESTING required to test memory protection';
  25         exit;
  26     }
  27     if (!can_fork || !try_load_optional('POSIX::1003')) {
  28         plan skip_all => 'fork and POSIX::1003 required to test memory protection';
  29         exit;
  30     }
  31     POSIX::1003->import(':rlimit');
  32 }
  33
  34 my $BLOCK_SIZE = 8196;
  35
  36 -e 'core' && die "Remove or move the core dump!\n";
  37 my $cleanup = Scope::Guard->new(sub { unlink('core') });
  38
  39 my ($cur, $max, $success) = getrlimit('RLIMIT_CORE');
  40 $success or die "getrlimit failed: $!\n";
  41 if ($cur < 1<<16) {
  42     setrlimit('RLIMIT_CORE', RLIM_INFINITY, RLIM_INFINITY) or die "setrlimit failed: $!\n";
  43 }
  44
  45 my $SECRET = 'c3VwZXJjYWxpZnJhZ2lsaXN0aWM=';
  46 my $SECRET_SHA256 = 'y1cOWidI80n5EZQx24NrOiP9tlca/uNMBDLYciDyQxs=';
  47
  48 for my $test (
  49     {
  50         test    => 'secret in scope',
  51         run     => sub {
  52             my $secret = decode_b64($SECRET);
  53             dump_core();
  54         },
  55         strings => [
  56             $SECRET => 1,
  57         ],
  58     },
  59     {
  60         test    => 'erased secret',
  61         run     => sub {
  62             my $secret = decode_b64($SECRET);
  63             erase $secret;
  64             dump_core();
  65         },
  66         strings => [
  67             $SECRET => 0,
  68         ],
  69     },
  70     {
  71         test    => 'Key password',
  72         run     => sub {
  73             my $password = decode_b64($SECRET);
  74             my $key = File::KDBX::Key->new($password);
  75             erase $password;
  76             dump_core();
  77         },
  78         strings => [
  79             $SECRET => 0,
  80         ],
  81     },
  82     {
  83         test    => 'Key password, raw key shown',
  84         run     => sub {
  85             my $password = decode_b64($SECRET);
  86             my $key = File::KDBX::Key->new($password);
  87             erase $password;
  88             $key->show;
  89             dump_core();
  90         },
  91         strings => [
  92             $SECRET         => 0,
  93             $SECRET_SHA256  => 1,
  94         ],
  95     },
  96     {
  97         test    => 'Key password, raw key hidden',
  98         run     => sub {
  99             my $password = decode_b64($SECRET);
 100             my $key = File::KDBX::Key->new($password);
 101             erase $password;
 102             $key->show->hide for 0..500;
 103             dump_core();
 104         },
 105         strings => [
 106             $SECRET         => 0,
 107             $SECRET_SHA256  => 0,
 108         ],
 109     },
 110     {
 111         test    => 'protected strings and keys',
 112         run     => sub {
 113             my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw');
 114             dump_core();
 115         },
 116         strings => [
 117             'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 0, # Password
 118             'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 0,
 119             # Secret A:
 120             'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 0, # Secret B
 121             'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret
 122             'SlHA3Eyhomr/UQ6vznWMRZtxlrqIm/tM3qVZv7G31DU=' => 0, # Final key
 123             'LuVqNfGluvLPcg2W699/Q6WGxIztX7Jvw0ONwQEi/Jc=' => 0, # Transformed key
 124             # HMAC key:
 125             'kDEMVEcGR32UXTwG8j3SxsfdF+l124Ni6iHeogCWGd2z0KSG5PosDTloxC0zg7Ucn2CNR6f2wpgzcVGKmDNFCA==' => 0,
 126             # Inner random stream key:
 127             'SwJSukmQdZKpHm8PywqLu1EHfUzS/gyJsg61Cm74YeRJeOpDlFblbVd5d4p+lU2/7Q28Vk4j/E2RRMC81DXdUw==' => 1,
 128             'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 1, # Random stream key (actual)
 129         ],
 130     },
 131     {
 132         test    => 'inner random stream key replaced',
 133         run     => sub {
 134             my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw');
 135             $kdbx->inner_random_stream_key("\1" x 64);
 136             dump_core();
 137         },
 138         strings => [
 139             # Inner random stream key:
 140             # FIXME - there is second copy of this key somewhere... in another SvPV?
 141             'SwJSukmQdZKpHm8PywqLu1EHfUzS/gyJsg61Cm74YeRJeOpDlFblbVd5d4p+lU2/7Q28Vk4j/E2RRMC81DXdUw==' => undef,
 142         ],
 143     },
 144     {
 145         test    => 'protected strings revealed',
 146         run     => sub {
 147             my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw');
 148             $kdbx->unlock;
 149             dump_core();
 150         },
 151         strings => [
 152             'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 1, # Password
 153             # Secret A:
 154             'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 1,
 155             'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 1, # Secret B
 156             'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret
 157             'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 0, # Random stream key (actual)
 158         ],
 159     },
 160     {
 161         test    => 'protected strings previously-revealed',
 162         run     => sub {
 163             my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw');
 164             $kdbx->unlock;
 165             $kdbx->lock;
 166             dump_core();
 167         },
 168         strings => [
 169             'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 0, # Password
 170             # Secret A:
 171             'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 0,
 172             'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 0, # Secret B
 173             'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret
 174             'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 0, # Random stream key (actual)
 175         ],
 176     },
 177 ) {
 178     my ($description, $run, $strings) = @$test{qw(test run strings)};
 179
 180     subtest "Dump core with $description" => sub {
 181         my @strings = @_;
 182         my $num_strings = @strings / 2;
 183         plan tests => 2 + $num_strings * 2;
 184
 185         my (@encoded_strings, @expected);
 186         while (@strings) {
 187             my ($string, $expected) = splice @strings, 0, 2;
 188             push @encoded_strings, $string;
 189             push @expected, $expected;
 190         }
 191
 192         my ($dumped, $has_core, @matches) = run_test($run, @encoded_strings);
 193
 194         ok $dumped, 'Test process signaled that it core-dumped';
 195         ok $has_core, 'Found core dump' or return;
 196
 197         note sprintf('core dump is %.1f MiB', (-s 'core')/1048576);
 198
 199         for (my $i = 1; $i <= $num_strings; ++$i) {
 200             my $count    = $matches[$i - 1];
 201             my $string   = $encoded_strings[$i - 1];
 202             my $expected = $expected[$i - 1];
 203
 204             ok defined $count, "[#$i] Got result from test environment";
 205
 206             TODO: {
 207                 local $TODO = 'Unprotected memory!' if !defined $expected;
 208                 if ($expected) {
 209                     ok 0 < $count, "[#$i] String FOUND"
 210                         or diag "Found $count copies of string #$i\nString: $string";
 211                 }
 212                 else {
 213                     is $count, 0, "[#$i] String MISSING"
 214                         or diag "Found $count copies of string #$i\nString: $string";
 215                 }
 216             }
 217         }
 218     }, @$strings;
 219 }
 220
 221 done_testing;
 222 exit;
 223
 224 ##############################################################################
 225
 226 sub dump_core { kill 'QUIT', $$ }
 227
 228 sub file_grep {
 229     my $filepath = shift;
 230     my @strings = @_;
 231
 232     my $counter = 0;
 233     my %counts = map { $_ => $counter++ } @strings;
 234     my @counts = map { 0 } @strings;
 235
 236     my $pattern = join('|', map { quotemeta($_) } @strings);
 237
 238     my $overlap = (max map { length } @strings) - 1;
 239
 240     open(my $fh, '<:raw', $filepath) or die "open failed: $!\n";
 241
 242     my $previous;
 243     while (read $fh, my $block, $BLOCK_SIZE) {
 244         substr($block, 0, 0, substr($previous, -$overlap)) if defined $previous;
 245
 246         while ($block =~ /($pattern)/gs) {
 247             ++$counts[$counts{$1}];
 248         }
 249         $previous = substr($block, $overlap);
 250     }
 251     die "read error: $!" if $fh->error;
 252
 253     return @counts;
 254 }
 255
 256 sub run_test {
 257     my $code = shift;
 258     my @strings = @_;
 259
 260     my $seed = random_bytes(32);
 261
 262     pipe(my $read, my $write) or die "pipe failed: $!\n";
 263
 264     defined(my $pid = fork) or die "fork failed: $!\n";
 265     if (!$pid) { # child
 266         close($read);
 267
 268         my $exit_status = run_doomed_child($code, $seed);
 269         my $dumped = $exit_status & 127 && $exit_status & 128;
 270
 271         my @decoded_strings = map { decode_b64($_) } @strings;
 272
 273         my @matches = file_grep('core', @decoded_strings);
 274         print $write join('|', $dumped, -f 'core' ? 1 : 0, @matches);
 275         close($write);
 276
 277         POSIX::_exit(0);
 278     }
 279
 280     close($write);
 281     my $results = do { local $/; <$read> };
 282
 283     waitpid($pid, 0);
 284     my $exit_status = $? >> 8;
 285     $exit_status == 0 or die "test environment exited non-zero: $exit_status\n";
 286
 287     return split(/\|/, $results);
 288 }
 289
 290 sub run_doomed_child {
 291     my $code = shift;
 292     my $seed = shift;
 293
 294     unlink('core') or die "unlink failed: $!\n" if -f 'core';
 295
 296     defined(my $pid = fork) or die "fork failed: $!\n";
 297     if (!$pid) { # child
 298         $code->();
 299         dump_core();        # doomed
 300         POSIX::_exit(1);    # paranoid
 301     }
 302
 303     waitpid($pid, 0);
 304     return $?;
 305 }