multiplex IO to prevent deadlocks

diff --git a/lib/File/KDBX/Key/YubiKey.pm b/lib/File/KDBX/Key/YubiKey.pm
index e86b6e786a5246b3b2d21189f4e7a112312bb16a..7b7132cc1065201b99f6238f525ec2de428314a0 100644 (file)
--- a/lib/File/KDBX/Key/YubiKey.pm
+++ b/lib/File/KDBX/Key/YubiKey.pm
@@ -6,10 +6,9 @@ use strict;
 
 use File::KDBX::Constants qw(:yubikey);
 use File::KDBX::Error;
-use File::KDBX::Util qw(pad_pkcs7);
-use IPC::Open3;
+use File::KDBX::Util qw(:io pad_pkcs7);
+use IPC::Cmd 0.52 qw(run_forked);
 use Ref::Util qw(is_arrayref);
-use Scope::Guard;
 use Symbol qw(gensym);
 use namespace::clean;
 
@@ -25,8 +24,6 @@ sub challenge {
     my $challenge = shift;
     my %args = @_;
 
-    my @cleanup;
-
     my $device  = $args{device}  // $self->device;
     my $slot    = $args{slot}    // $self->slot;
     my $timeout = $args{timeout} // $self->timeout;
@@ -40,43 +37,33 @@ sub challenge {
     }
 
     my @cmd = ($self->_program('ykchalresp'), "-n$device", "-$slot", qw{-H -i-}, $timeout == 0 ? '-N' : ());
-    my ($pid, $child_in, $child_out, $child_err) = _run_ykpers(@cmd);
-    push @cleanup, Scope::Guard->new(sub { kill $pid if defined $pid });
+    my $r = $self->_run_ykpers(\@cmd, {
+        (0 < $timeout ? (timeout => $timeout) : ()),
+        child_stdin                         => pad_pkcs7($challenge, 64),
+        terminate_on_parent_sudden_death    => 1,
+    });
 
-    # Set up an alarm [mostly] safely
-    my $prev_alarm = 0;
-    local $SIG{ALRM} = sub {
-        $prev_alarm -= $timeout;
+    if (my $t = $r->{timeout}) {
         throw 'Timed out while waiting for challenge response',
             command     => \@cmd,
             challenge   => $challenge,
-            timeout     => $timeout,
-    };
-    $prev_alarm = alarm $timeout if 0 < $timeout;
-    push @cleanup, Scope::Guard->new(sub { alarm($prev_alarm < 1 ? 1 : $prev_alarm) }) if $prev_alarm;
-
-    local $SIG{PIPE} = 'IGNORE';
-    binmode($child_in);
-    print $child_in pad_pkcs7($challenge, 64);
-    close($child_in);
-
-    binmode($child_out);
-    binmode($child_err);
-    my $resp = do { local $/; <$child_out> };
-    my $err  = do { local $/; <$child_err> };
-    chomp($resp, $err);
-
-    waitpid($pid, 0);
-    undef $pid;
-    my $exit_status = $? >> 8;
-    alarm 0;
-
-    my $yk_errno = _yk_errno($err);
-    $exit_status == 0 or throw 'Failed to receive challenge response: ' . ($err ? $err : ''),
-        error       => $err,
-        yk_errno    => $yk_errno || 0;
-
-    $resp =~ /^[A-Fa-f0-9]+$/ or throw 'Unexpected response from challenge', response => $resp;
+            timeout     => $t,
+            result      => $r;
+    }
+
+    my $exit_code = $r->{exit_code};
+    if ($exit_code != 0) {
+        my $err = $r->{stderr};
+        chomp $err;
+        my $yk_errno = _yk_errno($err);
+        throw 'Failed to receive challenge response: ' . ($err ? $err : ''),
+            error       => $err,
+            yk_errno    => $yk_errno || 0;
+    }
+
+    my $resp = $r->{stdout};
+    chomp $resp;
+    $resp =~ /^[A-Fa-f0-9]+$/ or throw 'Unexpected response from challenge', response => $resp, result => $r;
     $resp = pack('H*', $resp);
 
     # HMAC-SHA1 response is only 20 bytes
@@ -311,25 +298,20 @@ sub _get_yubikey_info {
     my $self = shift;
     my $device = shift;
 
+    my $timeout = $self->timeout;
     my @cmd = ($self->_program('ykinfo'), "-n$device", qw{-a});
 
     my $try = 0;
     TRY:
-    my ($pid, $child_in, $child_out, $child_err) = _run_ykpers(@cmd);
-
-    close($child_in);
-
-    local $SIG{PIPE} = 'IGNORE';
-    binmode($child_out);
-    binmode($child_err);
-    my $out = do { local $/; <$child_out> };
-    my $err = do { local $/; <$child_err> };
-    chomp $err;
-
-    waitpid($pid, 0);
-    my $exit_status = $? >> 8;
+    my $r = $self->_run_ykpers(\@cmd, {
+        (0 < $timeout ? (timeout => $timeout) : ()),
+        terminate_on_parent_sudden_death    => 1,
+    });
 
-    if ($exit_status != 0) {
+    my $exit_code = $r->{exit_code};
+    if ($exit_code != 0) {
+        my $err = $r->{stderr};
+        chomp $err;
         my $yk_errno = _yk_errno($err);
         return if $yk_errno == YK_ENOKEY;
         if ($yk_errno == YK_EWOULDBLOCK && ++$try <= 3) {
@@ -342,6 +324,8 @@ sub _get_yubikey_info {
         return;
     }
 
+    my $out = $r->{stdout};
+    chomp $out;
     if (!$out) {
         alert 'Failed to get YubiKey device info: no output';
         return;
@@ -373,13 +357,23 @@ sub _program {
 }
 
 sub _run_ykpers {
-    my ($child_err, $child_in, $child_out) = (gensym);
-    my $pid = eval { open3($child_in, $child_out, $child_err, @_) };
-    if (my $err = $@) {
-        throw "Failed to run $_[0] - Make sure you have the YubiKey Personalization Tool (CLI) package installed.\n",
+    my $self = shift;
+    my $ppid = $$;
+    my $r = eval { run_forked(@_) };
+    my $err = $@;
+    if ($$ != $ppid) {
+        # Work around IPC::Cmd bug where child can return from run_forked.
+        # https://rt.cpan.org/Public/Bug/Display.html?id=127372
+        require POSIX;
+        POSIX::_exit(0);
+    }
+    if ($err || ($r->{exit_code} == 0 && $r->{err_msg} eq '' && $r->{stdout} eq '' && $r->{stderr} eq '')) {
+        $err //= 'No output';
+        my $prog = $_[0][0];
+        throw "Failed to run $prog - Make sure you have the YubiKey Personalization Tool (CLI) package installed.\n",
             error => $err;
     }
-    return ($pid, $child_in, $child_out, $child_err);
+    return $r;
 }
 
 sub _yk_errno {
@@ -455,4 +449,11 @@ B<YubiKey> searches for these programs in the same way perl typically searches f
 C<PATH> environment variable on many platforms). If the programs aren't installed normally, or if you want to
 override the default programs, these environment variables can be used.
 
+=head1 CAVEATS
+
+This doesn't work yet on Windows, probably. The hangup is pretty silly: IPC. Theoretically it would work if
+C<run_forked> from L<IPC::Cmd> worked in Windows, but it probably doesn't. I spent a couple hours applying
+various quirks to L<IPC::Open3> and L<IPC::Cmd> implementations but never quite got it to worked reliably
+without deadlocks. Maybe I'll revisit this later. Hit me up so I know if there's demand.
+
 =cut

diff --git a/t/yubikey.t b/t/yubikey.t
index 61ca28ca1d25a9e662533db2eeaa8bffc46fa4b8..b325b25e262f9d0caf8582183713678d982290ce 100644 (file)
--- a/t/yubikey.t
+++ b/t/yubikey.t
@@ -10,6 +10,8 @@ use Config;
 use File::KDBX::Key::YubiKey;
 use Test::More;
 
+$^O eq 'MSWin32' and plan skip_all => 'Non-Windows required to test YubiKeys';
+
 @ENV{qw(YKCHALRESP YKCHALRESP_FLAGS)}   = ($Config{perlpath}, testfile(qw{bin ykchalresp}));
 @ENV{qw(YKINFO YKINFO_FLAGS)}           = ($Config{perlpath}, testfile(qw{bin ykinfo}));
 
@@ -50,7 +52,7 @@ use Test::More;
 
     $key->timeout(1);
     like exception { $key->challenge('foo') }, qr/timed out/i,
-        'Timed out while waiting for response';
+        'Timeout while waiting for response';
 
     $key->timeout(-1);
     my $resp;
@@ -63,14 +65,14 @@ use Test::More;
     my $key = File::KDBX::Key::YubiKey->new(device => 0, slot => 1);
     is $key->name, 'YubiKey NEO FIDO v2.0.0 [123] (slot #1)',
         'Get name for a new, unscanned key';
-    is $key->serial, 123, 'We have the serial number of the new key';
+    is $key->serial, 123, 'Get the serial number of the new key';
 }
 
 {
     my ($key, @other) = File::KDBX::Key::YubiKey->scan;
     is $key->name, 'YubiKey 4/5 OTP v3.0.1 [456] (slot #2)',
         'Find expected YubiKey';
-    is $key->serial, 456, 'We have the serial number of the scanned key';
+    is $key->serial, 456, 'Get the serial number of the scanned key';
     is scalar @other, 0, 'Do not find any other YubiKeys';
 }