1 package File
::KDBX
::Key
::YubiKey
;
2 # ABSTRACT: A Yubico challenge-response key
7 use File
::KDBX
::Constants
qw(:yubikey);
9 use File
::KDBX
::Util
qw(:class :io pad_pkcs7);
10 use IPC
::Cmd
0.52 qw(run_forked);
11 use Ref
::Util
qw(is_arrayref);
12 use Symbol
qw(gensym);
15 extends
'File::KDBX::Key::ChallengeResponse';
17 our $VERSION = '0.900'; # VERSION
19 # It can take some time for the USB device to be ready again, so we can retry a few times.
21 our $RETRY_INTERVAL = 0.1;
23 my @CONFIG_VALID = (0, CONFIG1_VALID
, CONFIG2_VALID
);
24 my @CONFIG_TOUCH = (0, CONFIG1_TOUCH
, CONFIG2_TOUCH
);
28 my $challenge = shift;
31 my $device = $args{device
} // $self->device;
32 my $slot = $args{slot
} // $self->slot;
33 my $timeout = $args{timeout
} // $self->timeout;
34 local $self->{device
} = $device;
35 local $self->{slot
} = $slot;
36 local $self->{timeout
} = $timeout;
38 my $hooks = $challenge ne 'test';
39 if ($hooks and my $hook = $self->{pre_challenge
}) {
40 $hook->($self, $challenge);
43 my @cmd = ($self->_program('ykchalresp'), "-n$device", "-$slot", qw{-H -i-}, $timeout == 0 ? '-N' : ());
49 $r = $self->_run_ykpers(\
@cmd, {
50 (0 < $timeout ? (timeout
=> $timeout) : ()),
51 child_stdin
=> pad_pkcs7
($challenge, 64),
52 terminate_on_parent_sudden_death
=> 1,
55 if (my $t = $r->{timeout
}) {
56 throw
'Timed out while waiting for challenge response',
58 challenge
=> $challenge,
63 my $exit_code = $r->{exit_code
};
64 if ($exit_code != 0) {
65 my $err = $r->{stderr
};
67 my $yk_errno = _yk_errno
($err);
68 if ($yk_errno == YK_EUSBERR
&& $err =~ /resource busy/i && ++$try <= $RETRY_COUNT) {
69 sleep $RETRY_INTERVAL;
72 throw
'Failed to receive challenge response: ' . ($err ? $err : 'Something happened'),
74 yk_errno
=> $yk_errno || 0;
78 my $resp = $r->{stdout
};
80 $resp =~ /^[A-Fa-f0-9]+$/ or throw
'Unexpected response from challenge', response
=> $resp, result
=> $r;
81 $resp = pack('H*', $resp);
83 # HMAC-SHA1 response is only 20 bytes
84 substr($resp, 20) = '';
86 if ($hooks and my $hook = $self->{post_challenge
}) {
87 $hook->($self, $challenge, $resp);
98 my $limit = delete $args{limit
} // 4;
101 for (my $device = 0; $device < $limit; ++$device) {
102 my %info = $self->_get_yubikey_info($device) or last;
104 for (my $slot = 1; $slot <= 2; ++$slot) {
105 my $config = $CONFIG_VALID[$slot] // next;
106 next unless $info{touch_level
} & $config;
108 my $key = $self->new(%args, device
=> $device, slot
=> $slot, %info);
109 if ($info{product_id
} <= NEO_OTP_U2F_CCID_PID
) {
110 # NEO and earlier always require touch, so forego testing
111 $key->touch_level($info{touch_level
} | $CONFIG_TOUCH[$slot]);
115 eval { $key->challenge('test', timeout
=> 0) };
117 my $yk_errno = ref $err && $err->details->{yk_errno
} || 0;
118 if ($yk_errno == YK_EWOULDBLOCK
) {
119 $key->touch_level($info{touch_level
} | $CONFIG_TOUCH[$slot]);
121 elsif ($yk_errno != 0) {
138 has pre_challenge
=> undef;
139 has post_challenge
=> undef;
140 has ykchalresp
=> sub { $ENV{YKCHALRESP
} || 'ykchalresp' };
141 has ykinfo
=> sub { $ENV{YKINFO
} || 'ykinfo' };
144 has serial
=> sub { $_[0]->_set_yubikey_info; $_[0]->{serial
} };
145 has version
=> sub { $_[0]->_set_yubikey_info; $_[0]->{version
} };
146 has touch_level
=> sub { $_[0]->_set_yubikey_info; $_[0]->{touch_level
} };
147 has vendor_id
=> sub { $_[0]->_set_yubikey_info; $_[0]->{vendor_id
} };
148 has product_id
=> sub { $_[0]->_set_yubikey_info; $_[0]->{product_id
} };
153 my $name = _product_name
($self->vendor_id, $self->product_id // return);
154 my $serial = $self->serial;
155 my $version = $self->version || '?';
156 my $slot = $self->slot;
157 my $touch = $self->requires_interaction ? ' - Interaction required' : '';
158 return sprintf('%s v%s [%d] (slot #%d)', $name, $version, $serial, $slot);
162 sub requires_interaction
{
164 my $touch = $self->touch_level // return;
165 return $touch & $CONFIG_TOUCH[$self->slot];
168 ##############################################################################
170 ### Call ykinfo to get some information about a YubiKey
171 sub _get_yubikey_info
{
175 my $timeout = $self->timeout;
176 my @cmd = ($self->_program('ykinfo'), "-n$device", qw{-a});
182 $r = $self->_run_ykpers(\
@cmd, {
183 (0 < $timeout ? (timeout
=> $timeout) : ()),
184 terminate_on_parent_sudden_death
=> 1,
187 my $exit_code = $r->{exit_code
};
188 if ($exit_code != 0) {
189 my $err = $r->{stderr
};
191 my $yk_errno = _yk_errno
($err);
192 return if $yk_errno == YK_ENOKEY
;
193 if ($yk_errno == YK_EWOULDBLOCK
&& ++$try <= $RETRY_COUNT) {
194 sleep $RETRY_INTERVAL;
197 alert
'Failed to get YubiKey device info: ' . ($err ? $err : 'Something happened'),
199 yk_errno
=> $yk_errno || 0;
204 my $out = $r->{stdout
};
207 alert
'Failed to get YubiKey device info: no output';
211 my %info = map { $_ => ($out =~ /^\Q$_\E: (.+)$/m)[0] }
212 qw(serial version touch_level vendor_id product_id);
213 $info{vendor_id
} = hex($info{vendor_id
}) if defined $info{vendor_id
};
214 $info{product_id
} = hex($info{product_id
}) if defined $info{product_id
};
219 ### Set the YubiKey information as attributes of a Key object
220 sub _set_yubikey_info
{
222 my %info = $self->_get_yubikey_info($self->device);
223 @$self{keys %info} = values %info;
229 my @cmd = $self->$name // $name;
230 my $name_uc = uc($name);
231 my $flags = $ENV{"${name_uc}_FLAGS"};
232 push @cmd, split(/\h+/, $flags) if $flags;
239 my $r = eval { run_forked
(@_) };
242 # Work around IPC::Cmd bug where child can return from run_forked.
243 # https://rt.cpan.org/Public/Bug/Display.html?id=127372
247 if ($err || ($r->{exit_code
} == 0 && $r->{err_msg
} eq '' && $r->{stdout
} eq '' && $r->{stderr
} eq '')) {
248 $err //= 'No output';
250 throw
"Failed to run $prog - Make sure you have the YubiKey Personalization Tool (CLI) package installed.\n",
257 local $_ = shift or return 0;
258 return YK_EUSBERR
if $_ =~ YK_EUSBERR
;
259 return YK_EWRONGSIZ
if $_ =~ YK_EWRONGSIZ
;
260 return YK_EWRITEERR
if $_ =~ YK_EWRITEERR
;
261 return YK_ETIMEOUT
if $_ =~ YK_ETIMEOUT
;
262 return YK_ENOKEY
if $_ =~ YK_ENOKEY
;
263 return YK_EFIRMWARE
if $_ =~ YK_EFIRMWARE
;
264 return YK_ENOMEM
if $_ =~ YK_ENOMEM
;
265 return YK_ENOSTATUS
if $_ =~ YK_ENOSTATUS
;
266 return YK_ENOTYETIMPL
if $_ =~ YK_ENOTYETIMPL
;
267 return YK_ECHECKSUM
if $_ =~ YK_ECHECKSUM
;
268 return YK_EWOULDBLOCK
if $_ =~ YK_EWOULDBLOCK
;
269 return YK_EINVALIDCMD
if $_ =~ YK_EINVALIDCMD
;
270 return YK_EMORETHANONE
if $_ =~ YK_EMORETHANONE
;
271 return YK_ENODATA
if $_ =~ YK_ENODATA
;
277 YUBIKEY_PID
, NEO_OTP_PID
, NEO_OTP_CCID_PID
, NEO_CCID_PID
, NEO_U2F_PID
, NEO_OTP_U2F_PID
, NEO_U2F_CCID_PID
,
278 NEO_OTP_U2F_CCID_PID
, YK4_OTP_PID
, YK4_U2F_PID
, YK4_OTP_U2F_PID
, YK4_CCID_PID
, YK4_OTP_CCID_PID
,
279 YK4_U2F_CCID_PID
, YK4_OTP_U2F_CCID_PID
, PLUS_U2F_OTP_PID
, ONLYKEY_PID
,
281 $PIDS{$pid} = $PIDS{0+$pid} = $pid;
283 sub _product_name
{ $PIDS{$_[1]} // 'Unknown' }
295 File::KDBX::Key::YubiKey - A Yubico challenge-response key
303 use File::KDBX::Key::YubiKey;
306 my $yubikey = File::KDBX::Key::YubiKey->new(%attributes);
308 my $kdbx = File::KDBX->load_file('database.kdbx', $yubikey);
310 my $kdbx = File::KDBX->load_file('database.kdbx', ['password', $yubikey]);
312 # Scan for USB YubiKeys:
313 my ($first_key, @other_keys) = File::KDBX::Key::YubiKey->scan;
315 my $response = $first_key->challenge('hello');
319 A L<File::KDBX::Key::YubiKey> is a type of challenge-response key. This module follows the KeePassXC-style
320 challenge-response implementation, so this might not work at all with incompatible challenge-response
321 implementations (e.g. KeeChallenge).
323 Inherets methods and attributes from L<File::KDBX::Key::ChallengeResponse>.
325 To use this type of key to secure a L<File::KDBX> database, you also need to install the
326 L<YubiKey Personalization Tool (CLI)|https://developers.yubico.com/yubikey-personalization/> and configure at
327 least one of the slots on your YubiKey for HMAC-SHA1 challenge response mode. You can use the YubiKey
328 Personalization Tool GUI to do this.
330 See L<https://keepassxc.org/docs/#faq-yubikey-howto> for more information.
336 $device = $key->device($device);
338 Get or set the device number, which is the index number starting and incrementing from zero assigned
339 to the YubiKey device. If there is only one detected YubiKey device, it's number is C<0>.
345 $slot = $key->slot($slot);
347 Get or set the slot number, which is a number starting and incrementing from one. A YubiKey can have
348 multiple slots (often just two) which can be independently configured.
354 $timeout = $key->timeout($timeout);
356 Get or set the timeout, in seconds. If the challenge takes longer than this, the challenge will be
357 cancelled and an error is thrown.
359 If the timeout is zero, the challenge is non-blocking; an error is thrown if the challenge would
360 block. If the timeout is negative, timeout is disabled and the challenge will block forever or until
361 a response is received.
367 $callback = $key->pre_challenge($callback);
369 Get or set a callback function that will be called immediately before any challenge is issued. This might be
370 used to prompt the user so they are aware that they are expected to interact with their YubiKey.
372 $key->pre_challenge(sub {
373 my ($key, $challenge) = @_;
375 if ($key->requires_interaction) {
376 say 'Please touch your key device to proceed with decrypting your KDBX file.';
378 say 'Key: ', $key->name;
379 if (0 < $key->timeout) {
380 say 'Key access request expires: ' . localtime(time + $key->timeout);
384 You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping
385 a KDBX database, the entire load/dump will be aborted.
387 =head2 post_challenge
389 $callback = $key->post_challenge($callback);
391 Get or set a callback function that will be called immediately after a challenge response has been received.
393 You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping
394 a KDBX database, the entire load/dump will be aborted.
398 $program = $key->ykchalresp;
400 Get or set the L<ykchalresp(1)> program name or filepath. Defaults to C<$ENV{YKCHALRESP}> or C<ykchalresp>.
404 $program = $key->ykinfo;
406 Get or set the L<ykinfo(1)> program name or filepath. Defaults to C<$ENV{YKINFO}> or C<ykinfo>.
412 @keys = File::KDBX::Key::YubiKey->scan(%options);
414 Find connected, configured YubiKeys that are capable of responding to a challenge. This can take several
423 C<limit> - Scan for only up to this many YubiKeys (default: 4)
427 Other options are passed as-is as attributes to the key constructors of found keys (if any).
431 Get the device serial number, as a number, or C<undef> if there is no such device.
435 Get the device firmware version (or C<undef>).
439 Get the "touch level" value for the device associated with this key (or C<undef>).
445 Get the vendor ID or product ID for the device associated with this key (or C<undef>).
451 Get a human-readable string identifying the YubiKey (or C<undef>).
453 =head2 requires_interaction
455 Get whether or not the key requires interaction (e.g. a touch) to provide a challenge response (or C<undef>).
463 C<YKCHALRESP> - Path to the L<ykchalresp(1)> program
467 C<YKINFO> - Path to the L<ykinfo(1)> program
471 C<YKCHALRESP_FLAGS> - Extra arguments to the B<ykchalresp(1)> program
475 C<YKINFO_FLAGS> - Extra arguments to the B<ykinfo(1)> program
479 B<YubiKey> searches for these programs in the same way perl typically searches for executables (using the
480 C<PATH> environment variable on many platforms). If the programs aren't installed normally, or if you want to
481 override the default programs, these environment variables can be used.
485 This doesn't work yet on Windows, probably. The hangup is pretty silly: IPC. Theoretically it would work if
486 C<run_forked> from L<IPC::Cmd> worked in Windows, but it probably doesn't. I spent a couple hours applying
487 various quirks to L<IPC::Open3> and L<IPC::Cmd> implementations but never quite got it to worked reliably
488 without deadlocks. Maybe I'll revisit this later. Hit me up so I know if there's demand.
490 It would also be possible to implement this is an XS module that incorporated ykcore, using libusb-1 which
491 would probably make it more portable with Windows. Perhaps if I get around to it.
495 Please report any bugs or feature requests on the bugtracker website
496 L<https://github.com/chazmcgarvey/File-KDBX/issues>
498 When submitting a bug or request, please include a test-file or a
499 patch to an existing test-file that illustrates the bug or desired
504 Charles McGarvey <ccm@cpan.org>
506 =head1 COPYRIGHT AND LICENSE
508 This software is copyright (c) 2022 by Charles McGarvey.
510 This is free software; you can redistribute it and/or modify it under
511 the same terms as the Perl 5 programming language system itself.