From: Charles McGarvey Date: Thu, 14 Apr 2022 23:06:56 +0000 (-0600) Subject: multiplex IO to prevent deadlocks X-Git-Tag: v0.800~33 X-Git-Url: https://git.dogcows.com/gitweb?a=commitdiff_plain;h=b30990a507ef30b6f5b6fcb799a2759632c77ff0;p=chaz%2Fp5-File-KDBX multiplex IO to prevent deadlocks --- diff --git a/lib/File/KDBX/Key/YubiKey.pm b/lib/File/KDBX/Key/YubiKey.pm index e86b6e7..7b7132c 100644 --- 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 searches for these programs in the same way perl typically searches f C 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 from L worked in Windows, but it probably doesn't. I spent a couple hours applying +various quirks to L and L 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 61ca28c..b325b25 100644 --- 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'; }