use File::KDBX::Constants qw(:yubikey);
use File::KDBX::Error;
-use File::KDBX::Util qw(pad_pkcs7);
-use IPC::Open3;
-use Scope::Guard;
+use File::KDBX::Util qw(:io pad_pkcs7);
+use IPC::Cmd 0.52 qw(run_forked);
+use Ref::Util qw(is_arrayref);
use Symbol qw(gensym);
use namespace::clean;
our $VERSION = '999.999'; # VERSION
+# It can take some time for the USB device to be ready again, so we can retry a few times.
+our $RETRY_COUNT = 5;
+our $RETRY_INTERVAL = 0.1;
+
my @CONFIG_VALID = (0, CONFIG1_VALID, CONFIG2_VALID);
my @CONFIG_TOUCH = (0, CONFIG1_TOUCH, CONFIG2_TOUCH);
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;
$hook->($self, $challenge);
}
- my @cmd = ($self->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 });
-
- # Set up an alarm [mostly] safely
- my $prev_alarm = 0;
- local $SIG{ALRM} = sub {
- $prev_alarm -= $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;
+ my @cmd = ($self->_program('ykchalresp'), "-n$device", "-$slot", qw{-H -i-}, $timeout == 0 ? '-N' : ());
+
+ my $r;
+ my $try = 0;
+ TRY:
+ {
+ $r = $self->_run_ykpers(\@cmd, {
+ (0 < $timeout ? (timeout => $timeout) : ()),
+ child_stdin => pad_pkcs7($challenge, 64),
+ terminate_on_parent_sudden_death => 1,
+ });
+
+ if (my $t = $r->{timeout}) {
+ throw 'Timed out while waiting for challenge response',
+ command => \@cmd,
+ challenge => $challenge,
+ 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);
+ if ($yk_errno == YK_EUSBERR && $err =~ /resource busy/i && ++$try <= $RETRY_COUNT) {
+ sleep $RETRY_INTERVAL;
+ goto TRY;
+ }
+ throw 'Failed to receive challenge response: ' . ($err ? $err : 'Something happened'),
+ 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
my $self = shift;
my $device = shift;
- my @cmd = ($self->ykinfo, "-n$device", qw{-a});
+ my $timeout = $self->timeout;
+ my @cmd = ($self->_program('ykinfo'), "-n$device", qw{-a});
+ my $r;
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;
-
- if ($exit_status != 0) {
- my $yk_errno = _yk_errno($err);
- return if $yk_errno == YK_ENOKEY;
- if ($yk_errno == YK_EWOULDBLOCK && ++$try <= 3) {
- sleep 0.1;
- goto TRY;
+ {
+ $r = $self->_run_ykpers(\@cmd, {
+ (0 < $timeout ? (timeout => $timeout) : ()),
+ terminate_on_parent_sudden_death => 1,
+ });
+
+ 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 <= $RETRY_COUNT) {
+ sleep $RETRY_INTERVAL;
+ goto TRY;
+ }
+ alert 'Failed to get YubiKey device info: ' . ($err ? $err : 'Something happened'),
+ error => $err,
+ yk_errno => $yk_errno || 0;
+ return;
}
- alert 'Failed to get YubiKey device info: ' . ($err ? $err : 'Something happened'),
- error => $err,
- yk_errno => $yk_errno || 0;
- return;
}
+ my $out = $r->{stdout};
+ chomp $out;
if (!$out) {
alert 'Failed to get YubiKey device info: no output';
return;
@$self{keys %info} = values %info;
}
+sub _program {
+ my $self = shift;
+ my $name = shift;
+ my @cmd = $self->$name // $name;
+ my $name_uc = uc($name);
+ my $flags = $ENV{"${name_uc}_FLAGS"};
+ push @cmd, split(/\h+/, $flags) if $flags;
+ return @cmd;
+}
+
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",
- error => $err;
+ 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);
}
- return ($pid, $child_in, $child_out, $child_err);
+ 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 $r;
}
sub _yk_errno {
challenge-response implementation, so this might not work at all with incompatible challenge-response
implementations (e.g. KeeChallenge).
+Inherets methods and attributes from L<File::KDBX::Key::ChallengeResponse>.
+
To use this type of key to secure a L<File::KDBX> database, you also need to install the
L<YubiKey Personalization Tool (CLI)|https://developers.yubico.com/yubikey-personalization/> and configure at
least one of the slots on your YubiKey for HMAC-SHA1 challenge response mode. You can use the YubiKey
=for :list
* C<YKCHALRESP> - Path to the L<ykchalresp(1)> program
* C<YKINFO> - Path to the L<ykinfo(1)> program
+* C<YKCHALRESP_FLAGS> - Extra arguments to the B<ykchalresp(1)> program
+* C<YKINFO_FLAGS> - Extra arguments to the B<ykinfo(1)> program
-C<YubiKey> searches for these programs in the same way perl typically searches for executables (using the
+B<YubiKey> searches for these programs in the same way perl typically searches for executables (using the
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.
+
+It would also be possible to implement this is an XS module that incorporated ykcore, using libusb-1 which
+would probably make it more portable with Windows. Perhaps if I get around to it.
+
=cut
projects / chaz / p5-File-KDBX / blobdiff