Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Key/YubiKey.pm

   1 package File::KDBX::Key::YubiKey;
   2 # ABSTRACT: A Yubico challenge-response key
   3
   4 use warnings;
   5 use strict;
   6
   7 use File::KDBX::Constants qw(:yubikey);
   8 use File::KDBX::Error;
   9 use File::KDBX::Util qw(:class :io pad_pkcs7);
  10 use IPC::Cmd 0.84 qw(run_forked);
  11 use Ref::Util qw(is_arrayref);
  12 use Symbol qw(gensym);
  13 use namespace::clean;
  14
  15 extends 'File::KDBX::Key::ChallengeResponse';
  16
  17 our $VERSION = '0.903'; # VERSION
  18
  19 # It can take some time for the USB device to be ready again, so we can retry a few times.
  20 our $RETRY_COUNT    = 5;
  21 our $RETRY_INTERVAL = 0.1;
  22
  23 my @CONFIG_VALID = (0, CONFIG1_VALID, CONFIG2_VALID);
  24 my @CONFIG_TOUCH = (0, CONFIG1_TOUCH, CONFIG2_TOUCH);
  25
  26 sub challenge {
  27     my $self = shift;
  28     my $challenge = shift;
  29     my %args = @_;
  30
  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;
  37
  38     my $hooks = $challenge ne 'test';
  39     if ($hooks and my $hook = $self->{pre_challenge}) {
  40         $hook->($self, $challenge);
  41     }
  42
  43     my @cmd = ($self->_program('ykchalresp'), "-n$device", "-$slot", qw{-H -i-}, $timeout == 0 ? '-N' : ());
  44
  45     my $r;
  46     my $try = 0;
  47     TRY:
  48     {
  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,
  53         });
  54
  55         if (my $t = $r->{timeout}) {
  56             throw 'Timed out while waiting for challenge response',
  57                 command     => \@cmd,
  58                 challenge   => $challenge,
  59                 timeout     => $t,
  60                 result      => $r;
  61         }
  62
  63         my $exit_code = $r->{exit_code};
  64         if ($exit_code != 0) {
  65             my $err = $r->{stderr};
  66             chomp $err;
  67             my $yk_errno = _yk_errno($err);
  68             if ($yk_errno == YK_EUSBERR && $err =~ /resource busy/i && ++$try <= $RETRY_COUNT) {
  69                 sleep $RETRY_INTERVAL;
  70                 goto TRY;
  71             }
  72             throw 'Failed to receive challenge response: ' . ($err ? $err : 'Something happened'),
  73                 error       => $err,
  74                 yk_errno    => $yk_errno || 0;
  75         }
  76     }
  77
  78     my $resp = $r->{stdout};
  79     chomp $resp;
  80     $resp =~ /^[A-Fa-f0-9]+$/ or throw 'Unexpected response from challenge', response => $resp, result => $r;
  81     $resp = pack('H*', $resp);
  82
  83     # HMAC-SHA1 response is only 20 bytes
  84     substr($resp, 20) = '';
  85
  86     if ($hooks and my $hook = $self->{post_challenge}) {
  87         $hook->($self, $challenge, $resp);
  88     }
  89
  90     return $resp;
  91 }
  92
  93
  94 sub scan {
  95     my $self = shift;
  96     my %args = @_;
  97
  98     my $limit = delete $args{limit} // 4;
  99
 100     my @keys;
 101     for (my $device = 0; $device < $limit; ++$device) {
 102         my %info = $self->_get_yubikey_info($device) or last;
 103
 104         for (my $slot = 1; $slot <= 2; ++$slot) {
 105             my $config = $CONFIG_VALID[$slot] // next;
 106             next unless $info{touch_level} & $config;
 107
 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]);
 112                 push @keys, $key;
 113             }
 114             else {
 115                 eval { $key->challenge('test', timeout => 0) };
 116                 if (my $err = $@) {
 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]);
 120                     }
 121                     elsif ($yk_errno != 0) {
 122                         # alert $err;
 123                         next;
 124                     }
 125                 }
 126                 push @keys, $key;
 127             }
 128         }
 129     }
 130
 131     return @keys;
 132 }
 133
 134
 135 has device          => 0;
 136 has slot            => 1;
 137 has timeout         => 10;
 138 has pre_challenge   => undef;
 139 has post_challenge  => undef;
 140 has ykchalresp      => sub { $ENV{YKCHALRESP} || 'ykchalresp' };
 141 has ykinfo          => sub { $ENV{YKINFO}     || 'ykinfo' };
 142
 143
 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} };
 149
 150
 151 sub name {
 152     my $self = shift;
 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);
 159 }
 160
 161
 162 sub requires_interaction {
 163     my $self = shift;
 164     my $touch = $self->touch_level // return;
 165     return $touch & $CONFIG_TOUCH[$self->slot];
 166 }
 167
 168 ##############################################################################
 169
 170 ### Call ykinfo to get some information about a YubiKey
 171 sub _get_yubikey_info {
 172     my $self = shift;
 173     my $device = shift;
 174
 175     my $timeout = $self->timeout;
 176     my @cmd = ($self->_program('ykinfo'), "-n$device", qw{-a});
 177
 178     my $r;
 179     my $try = 0;
 180     TRY:
 181     {
 182         $r = $self->_run_ykpers(\@cmd, {
 183             (0 < $timeout ? (timeout => $timeout) : ()),
 184             terminate_on_parent_sudden_death    => 1,
 185         });
 186
 187         my $exit_code = $r->{exit_code};
 188         if ($exit_code != 0) {
 189             my $err = $r->{stderr};
 190             chomp $err;
 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;
 195                 goto TRY;
 196             }
 197             alert 'Failed to get YubiKey device info: ' . ($err ? $err : 'Something happened'),
 198                 error       => $err,
 199                 yk_errno    => $yk_errno || 0;
 200             return;
 201         }
 202     }
 203
 204     my $out = $r->{stdout};
 205     chomp $out;
 206     if (!$out) {
 207         alert 'Failed to get YubiKey device info: no output';
 208         return;
 209     }
 210
 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};
 215
 216     return %info;
 217 }
 218
 219 ### Set the YubiKey information as attributes of a Key object
 220 sub _set_yubikey_info {
 221     my $self = shift;
 222     my %info = $self->_get_yubikey_info($self->device);
 223     @$self{keys %info} = values %info;
 224 }
 225
 226 sub _program {
 227     my $self = shift;
 228     my $name = shift;
 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;
 233     return @cmd;
 234 }
 235
 236 sub _run_ykpers {
 237     my $self = shift;
 238     my $ppid = $$;
 239     my $r = eval { run_forked(@_) };
 240     my $err = $@;
 241     if ($$ != $ppid) {
 242         # Work around IPC::Cmd bug where child can return from run_forked.
 243         # https://rt.cpan.org/Public/Bug/Display.html?id=127372
 244         require POSIX;
 245         POSIX::_exit(0);
 246     }
 247     if ($err || ($r->{exit_code} == 0 && $r->{err_msg} eq '' && $r->{stdout} eq '' && $r->{stderr} eq '')) {
 248         $err //= 'No output';
 249         my $prog = $_[0][0];
 250         throw "Failed to run $prog - Make sure you have the YubiKey Personalization Tool (CLI) package installed.\n",
 251             error => $err;
 252     }
 253     return $r;
 254 }
 255
 256 sub _yk_errno {
 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;
 272     return -1;
 273 }
 274
 275 my %PIDS;
 276 for my $pid (
 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,
 280 ) {
 281     $PIDS{$pid} = $PIDS{0+$pid} = $pid;
 282 }
 283 sub _product_name { $PIDS{$_[1]} // 'Unknown' }
 284
 285 1;
 286
 287 __END__
 288
 289 =pod
 290
 291 =encoding UTF-8
 292
 293 =head1 NAME
 294
 295 File::KDBX::Key::YubiKey - A Yubico challenge-response key
 296
 297 =head1 VERSION
 298
 299 version 0.903
 300
 301 =head1 SYNOPSIS
 302
 303     use File::KDBX::Key::YubiKey;
 304     use File::KDBX;
 305
 306     my $yubikey = File::KDBX::Key::YubiKey->new(%attributes);
 307
 308     my $kdbx = File::KDBX->load_file('database.kdbx', $yubikey);
 309     # OR
 310     my $kdbx = File::KDBX->load_file('database.kdbx', ['password', $yubikey]);
 311
 312     # Scan for USB YubiKeys:
 313     my ($first_key, @other_keys) = File::KDBX::Key::YubiKey->scan;
 314
 315     my $response = $first_key->challenge('hello');
 316
 317 =head1 DESCRIPTION
 318
 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).
 322
 323 Inherets methods and attributes from L<File::KDBX::Key::ChallengeResponse>.
 324
 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.
 329
 330 See L<https://keepassxc.org/docs/#faq-yubikey-howto> for more information.
 331
 332 =head1 ATTRIBUTES
 333
 334 =head2 device
 335
 336     $device = $key->device($device);
 337
 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>.
 340
 341 Defaults to C<0>.
 342
 343 =head2 slot
 344
 345     $slot = $key->slot($slot);
 346
 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.
 349
 350 Defaults to C<1>.
 351
 352 =head2 timeout
 353
 354     $timeout = $key->timeout($timeout);
 355
 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.
 358
 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.
 362
 363 Defaults to C<0>.
 364
 365 =head2 pre_challenge
 366
 367     $callback = $key->pre_challenge($callback);
 368
 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.
 371
 372     $key->pre_challenge(sub {
 373         my ($key, $challenge) = @_;
 374
 375         if ($key->requires_interaction) {
 376             say 'Please touch your key device to proceed with decrypting your KDBX file.';
 377         }
 378         say 'Key: ', $key->name;
 379         if (0 < $key->timeout) {
 380             say 'Key access request expires: ' . localtime(time + $key->timeout);
 381         }
 382     });
 383
 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.
 386
 387 =head2 post_challenge
 388
 389     $callback = $key->post_challenge($callback);
 390
 391 Get or set a callback function that will be called immediately after a challenge response has been received.
 392
 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.
 395
 396 =head2 ykchalresp
 397
 398     $program = $key->ykchalresp;
 399
 400 Get or set the L<ykchalresp(1)> program name or filepath. Defaults to C<$ENV{YKCHALRESP}> or C<ykchalresp>.
 401
 402 =head2 ykinfo
 403
 404     $program = $key->ykinfo;
 405
 406 Get or set the L<ykinfo(1)> program name or filepath. Defaults to C<$ENV{YKINFO}> or C<ykinfo>.
 407
 408 =head1 METHODS
 409
 410 =head2 scan
 411
 412     @keys = File::KDBX::Key::YubiKey->scan(%options);
 413
 414 Find connected, configured YubiKeys that are capable of responding to a challenge. This can take several
 415 second.
 416
 417 Options:
 418
 419 =over 4
 420
 421 =item *
 422
 423 C<limit> - Scan for only up to this many YubiKeys (default: 4)
 424
 425 =back
 426
 427 Other options are passed as-is as attributes to the key constructors of found keys (if any).
 428
 429 =head2 serial
 430
 431 Get the device serial number, as a number, or C<undef> if there is no such device.
 432
 433 =head2 version
 434
 435 Get the device firmware version (or C<undef>).
 436
 437 =head2 touch_level
 438
 439 Get the "touch level" value for the device associated with this key (or C<undef>).
 440
 441 =head2 vendor_id
 442
 443 =head2 product_id
 444
 445 Get the vendor ID or product ID for the device associated with this key (or C<undef>).
 446
 447 =head2 name
 448
 449     $name = $key->name;
 450
 451 Get a human-readable string identifying the YubiKey (or C<undef>).
 452
 453 =head2 requires_interaction
 454
 455 Get whether or not the key requires interaction (e.g. a touch) to provide a challenge response (or C<undef>).
 456
 457 =head1 ENVIRONMENT
 458
 459 =over 4
 460
 461 =item *
 462
 463 C<YKCHALRESP> - Path to the L<ykchalresp(1)> program
 464
 465 =item *
 466
 467 C<YKINFO> - Path to the L<ykinfo(1)> program
 468
 469 =item *
 470
 471 C<YKCHALRESP_FLAGS> - Extra arguments to the B<ykchalresp(1)> program
 472
 473 =item *
 474
 475 C<YKINFO_FLAGS> - Extra arguments to the B<ykinfo(1)> program
 476
 477 =back
 478
 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.
 482
 483 =head1 CAVEATS
 484
 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.
 489
 490 It would also be possible to implement this as 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.
 492
 493 =head1 BUGS
 494
 495 Please report any bugs or feature requests on the bugtracker website
 496 L<https://github.com/chazmcgarvey/File-KDBX/issues>
 497
 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
 500 feature.
 501
 502 =head1 AUTHOR
 503
 504 Charles McGarvey <ccm@cpan.org>
 505
 506 =head1 COPYRIGHT AND LICENSE
 507
 508 This software is copyright (c) 2022 by Charles McGarvey.
 509
 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.
 512
 513 =cut