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(:io pad_pkcs7);
  10 use IPC::Cmd 0.52 qw(run_forked);
  11 use Ref::Util qw(is_arrayref);
  12 use Symbol qw(gensym);
  13 use namespace::clean;
  14
  15 use parent 'File::KDBX::Key::ChallengeResponse';
  16
  17 our $VERSION = '999.999'; # 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 =method scan
  94
  95     @keys = File::KDBX::Key::YubiKey->scan(%options);
  96
  97 Find connected, configured YubiKeys that are capable of responding to a challenge. This can take several
  98 second.
  99
 100 Options:
 101
 102 =for :list
 103 * C<limit> - Scan for only up to this many YubiKeys (default: 4)
 104
 105 Other options are passed as-is as attributes to the key constructors of found keys (if any).
 106
 107 =cut
 108
 109 sub scan {
 110     my $self = shift;
 111     my %args = @_;
 112
 113     my $limit = delete $args{limit} // 4;
 114
 115     my @keys;
 116     for (my $device = 0; $device < $limit; ++$device) {
 117         my %info = $self->_get_yubikey_info($device) or last;
 118
 119         for (my $slot = 1; $slot <= 2; ++$slot) {
 120             my $config = $CONFIG_VALID[$slot] // next;
 121             next unless $info{touch_level} & $config;
 122
 123             my $key = $self->new(%args, device => $device, slot => $slot, %info);
 124             if ($info{product_id} <= NEO_OTP_U2F_CCID_PID) {
 125                 # NEO and earlier always require touch, so forego testing
 126                 $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]);
 127                 push @keys, $key;
 128             }
 129             else {
 130                 eval { $key->challenge('test', timeout => 0) };
 131                 if (my $err = $@) {
 132                     my $yk_errno = ref $err && $err->details->{yk_errno} || 0;
 133                     if ($yk_errno == YK_EWOULDBLOCK) {
 134                         $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]);
 135                     }
 136                     elsif ($yk_errno != 0) {
 137                         # alert $err;
 138                         next;
 139                     }
 140                 }
 141                 push @keys, $key;
 142             }
 143         }
 144     }
 145
 146     return @keys;
 147 }
 148
 149 =attr device
 150
 151     $device = $key->device($device);
 152
 153 Get or set the device number, which is the index number starting and incrementing from zero assigned
 154 to the YubiKey device. If there is only one detected YubiKey device, it's number is C<0>.
 155
 156 Defaults to C<0>.
 157
 158 =attr slot
 159
 160     $slot = $key->slot($slot);
 161
 162 Get or set the slot number, which is a number starting and incrementing from one. A YubiKey can have
 163 multiple slots (often just two) which can be independently configured.
 164
 165 Defaults to C<1>.
 166
 167 =attr timeout
 168
 169     $timeout = $key->timeout($timeout);
 170
 171 Get or set the timeout, in seconds. If the challenge takes longer than this, the challenge will be
 172 cancelled and an error is thrown.
 173
 174 If the timeout is zero, the challenge is non-blocking; an error is thrown if the challenge would
 175 block. If the timeout is negative, timeout is disabled and the challenge will block forever or until
 176 a response is received.
 177
 178 Defaults to C<0>.
 179
 180 =attr pre_challenge
 181
 182     $callback = $key->pre_challenge($callback);
 183
 184 Get or set a callback function that will be called immediately before any challenge is issued. This might be
 185 used to prompt the user so they are aware that they are expected to interact with their YubiKey.
 186
 187     $key->pre_challenge(sub {
 188         my ($key, $challenge) = @_;
 189
 190         if ($key->requires_interaction) {
 191             say 'Please touch your key device to proceed with decrypting your KDBX file.';
 192         }
 193         say 'Key: ', $key->name;
 194         if (0 < $key->timeout) {
 195             say 'Key access request expires: ' . localtime(time + $key->timeout);
 196         }
 197     });
 198
 199 You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping
 200 a KDBX database, the entire load/dump will be aborted.
 201
 202 =attr post_challenge
 203
 204     $callback = $key->post_challenge($callback);
 205
 206 Get or set a callback function that will be called immediately after a challenge response has been received.
 207
 208 You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping
 209 a KDBX database, the entire load/dump will be aborted.
 210
 211 =attr ykchalresp
 212
 213     $program = $key->ykchalresp;
 214
 215 Get or set the L<ykchalresp(1)> program name or filepath. Defaults to C<$ENV{YKCHALRESP}> or C<ykchalresp>.
 216
 217 =attr ykinfo
 218
 219     $program = $key->ykinfo;
 220
 221 Get or set the L<ykinfo(1)> program name or filepath. Defaults to C<$ENV{YKINFO}> or C<ykinfo>.
 222
 223 =cut
 224
 225 my %ATTRS = (
 226     device          => 0,
 227     slot            => 1,
 228     timeout         => 10,
 229     pre_challenge   => undef,
 230     post_challenge  => undef,
 231     ykchalresp      => sub { $ENV{YKCHALRESP} || 'ykchalresp' },
 232     ykinfo          => sub { $ENV{YKINFO} || 'ykinfo' },
 233 );
 234 while (my ($subname, $default) = each %ATTRS) {
 235     no strict 'refs'; ## no critic (ProhibitNoStrict)
 236     *{$subname} = sub {
 237         my $self = shift;
 238         $self->{$subname} = shift if @_;
 239         $self->{$subname} //= (ref $default eq 'CODE') ? $default->($self) : $default;
 240     };
 241 }
 242
 243 my %INFO = (
 244     serial      => undef,
 245     version     => undef,
 246     touch_level => undef,
 247     vendor_id   => undef,
 248     product_id  => undef,
 249 );
 250 while (my ($subname, $default) = each %INFO) {
 251     no strict 'refs'; ## no critic (ProhibitNoStrict)
 252     *{$subname} = sub {
 253         my $self = shift;
 254         $self->{$subname} = shift if @_;
 255         defined $self->{$subname} or $self->_set_yubikey_info;
 256         $self->{$subname} // $default;
 257     };
 258 }
 259
 260 =method serial
 261
 262 Get the device serial number, as a number, or C<undef> if there is no such device.
 263
 264 =method version
 265
 266 Get the device firmware version (or C<undef>).
 267
 268 =method touch_level
 269
 270 Get the "touch level" value for the device associated with this key (or C<undef>).
 271
 272 =method vendor_id
 273
 274 =method product_id
 275
 276 Get the vendor ID or product ID for the device associated with this key (or C<undef>).
 277
 278 =method name
 279
 280     $name = $key->name;
 281
 282 Get a human-readable string identifying the YubiKey (or C<undef>).
 283
 284 =cut
 285
 286 sub name {
 287     my $self = shift;
 288     my $name = _product_name($self->vendor_id, $self->product_id // return);
 289     my $serial = $self->serial;
 290     my $version = $self->version || '?';
 291     my $slot = $self->slot;
 292     my $touch = $self->requires_interaction ? ' - Interaction required' : '';
 293     return sprintf('%s v%s [%d] (slot #%d)', $name, $version, $serial, $slot);
 294 }
 295
 296 =method requires_interaction
 297
 298 Get whether or not the key requires interaction (e.g. a touch) to provide a challenge response (or C<undef>).
 299
 300 =cut
 301
 302 sub requires_interaction {
 303     my $self = shift;
 304     my $touch = $self->touch_level // return;
 305     return $touch & $CONFIG_TOUCH[$self->slot];
 306 }
 307
 308 ##############################################################################
 309
 310 ### Call ykinfo to get some information about a YubiKey
 311 sub _get_yubikey_info {
 312     my $self = shift;
 313     my $device = shift;
 314
 315     my $timeout = $self->timeout;
 316     my @cmd = ($self->_program('ykinfo'), "-n$device", qw{-a});
 317
 318     my $r;
 319     my $try = 0;
 320     TRY:
 321     {
 322         $r = $self->_run_ykpers(\@cmd, {
 323             (0 < $timeout ? (timeout => $timeout) : ()),
 324             terminate_on_parent_sudden_death    => 1,
 325         });
 326
 327         my $exit_code = $r->{exit_code};
 328         if ($exit_code != 0) {
 329             my $err = $r->{stderr};
 330             chomp $err;
 331             my $yk_errno = _yk_errno($err);
 332             return if $yk_errno == YK_ENOKEY;
 333             if ($yk_errno == YK_EWOULDBLOCK && ++$try <= $RETRY_COUNT) {
 334                 sleep $RETRY_INTERVAL;
 335                 goto TRY;
 336             }
 337             alert 'Failed to get YubiKey device info: ' . ($err ? $err : 'Something happened'),
 338                 error       => $err,
 339                 yk_errno    => $yk_errno || 0;
 340             return;
 341         }
 342     }
 343
 344     my $out = $r->{stdout};
 345     chomp $out;
 346     if (!$out) {
 347         alert 'Failed to get YubiKey device info: no output';
 348         return;
 349     }
 350
 351     my %info = map { $_ => ($out =~ /^\Q$_\E: (.+)$/m)[0] }
 352         qw(serial version touch_level vendor_id product_id);
 353     $info{vendor_id}    = hex($info{vendor_id})  if defined $info{vendor_id};
 354     $info{product_id}   = hex($info{product_id}) if defined $info{product_id};
 355
 356     return %info;
 357 }
 358
 359 ### Set the YubiKey information as attributes of a Key object
 360 sub _set_yubikey_info {
 361     my $self = shift;
 362     my %info = $self->_get_yubikey_info($self->device);
 363     @$self{keys %info} = values %info;
 364 }
 365
 366 sub _program {
 367     my $self = shift;
 368     my $name = shift;
 369     my @cmd = $self->$name // $name;
 370     my $name_uc = uc($name);
 371     my $flags = $ENV{"${name_uc}_FLAGS"};
 372     push @cmd, split(/\h+/, $flags) if $flags;
 373     return @cmd;
 374 }
 375
 376 sub _run_ykpers {
 377     my $self = shift;
 378     my $ppid = $$;
 379     my $r = eval { run_forked(@_) };
 380     my $err = $@;
 381     if ($$ != $ppid) {
 382         # Work around IPC::Cmd bug where child can return from run_forked.
 383         # https://rt.cpan.org/Public/Bug/Display.html?id=127372
 384         require POSIX;
 385         POSIX::_exit(0);
 386     }
 387     if ($err || ($r->{exit_code} == 0 && $r->{err_msg} eq '' && $r->{stdout} eq '' && $r->{stderr} eq '')) {
 388         $err //= 'No output';
 389         my $prog = $_[0][0];
 390         throw "Failed to run $prog - Make sure you have the YubiKey Personalization Tool (CLI) package installed.\n",
 391             error => $err;
 392     }
 393     return $r;
 394 }
 395
 396 sub _yk_errno {
 397     local $_ = shift or return 0;
 398     return YK_EUSBERR       if $_ =~ YK_EUSBERR;
 399     return YK_EWRONGSIZ     if $_ =~ YK_EWRONGSIZ;
 400     return YK_EWRITEERR     if $_ =~ YK_EWRITEERR;
 401     return YK_ETIMEOUT      if $_ =~ YK_ETIMEOUT;
 402     return YK_ENOKEY        if $_ =~ YK_ENOKEY;
 403     return YK_EFIRMWARE     if $_ =~ YK_EFIRMWARE;
 404     return YK_ENOMEM        if $_ =~ YK_ENOMEM;
 405     return YK_ENOSTATUS     if $_ =~ YK_ENOSTATUS;
 406     return YK_ENOTYETIMPL   if $_ =~ YK_ENOTYETIMPL;
 407     return YK_ECHECKSUM     if $_ =~ YK_ECHECKSUM;
 408     return YK_EWOULDBLOCK   if $_ =~ YK_EWOULDBLOCK;
 409     return YK_EINVALIDCMD   if $_ =~ YK_EINVALIDCMD;
 410     return YK_EMORETHANONE  if $_ =~ YK_EMORETHANONE;
 411     return YK_ENODATA       if $_ =~ YK_ENODATA;
 412     return -1;
 413 }
 414
 415 my %PIDS;
 416 for my $pid (
 417     YUBIKEY_PID, NEO_OTP_PID, NEO_OTP_CCID_PID, NEO_CCID_PID, NEO_U2F_PID, NEO_OTP_U2F_PID, NEO_U2F_CCID_PID,
 418     NEO_OTP_U2F_CCID_PID, YK4_OTP_PID, YK4_U2F_PID, YK4_OTP_U2F_PID, YK4_CCID_PID, YK4_OTP_CCID_PID,
 419     YK4_U2F_CCID_PID, YK4_OTP_U2F_CCID_PID, PLUS_U2F_OTP_PID, ONLYKEY_PID,
 420 ) {
 421     $PIDS{$pid} = $PIDS{0+$pid} = $pid;
 422 }
 423 sub _product_name { $PIDS{$_[1]} // 'Unknown' }
 424
 425 1;
 426 __END__
 427
 428 =head1 SYNOPSIS
 429
 430     use File::KDBX::Key::YubiKey;
 431     use File::KDBX;
 432
 433     my $yubikey = File::KDBX::Key::YubiKey->new(%attributes);
 434
 435     my $kdbx = File::KDBX->load_file('database.kdbx', $yubikey);
 436     # OR
 437     my $kdbx = File::KDBX->load_file('database.kdbx', ['password', $yubikey]);
 438
 439     # Scan for USB YubiKeys:
 440     my ($first_key, @other_keys) = File::KDBX::Key::YubiKey->scan;
 441
 442     my $response = $first_key->challenge('hello');
 443
 444 =head1 DESCRIPTION
 445
 446 A L<File::KDBX::Key::YubiKey> is a type of challenge-response key. This module follows the KeePassXC-style
 447 challenge-response implementation, so this might not work at all with incompatible challenge-response
 448 implementations (e.g. KeeChallenge).
 449
 450 Inherets methods and attributes from L<File::KDBX::Key::ChallengeResponse>.
 451
 452 To use this type of key to secure a L<File::KDBX> database, you also need to install the
 453 L<YubiKey Personalization Tool (CLI)|https://developers.yubico.com/yubikey-personalization/> and configure at
 454 least one of the slots on your YubiKey for HMAC-SHA1 challenge response mode. You can use the YubiKey
 455 Personalization Tool GUI to do this.
 456
 457 See L<https://keepassxc.org/docs/#faq-yubikey-howto> for more information.
 458
 459 =head1 ENVIRONMENT
 460
 461 =for :list
 462 * C<YKCHALRESP> - Path to the L<ykchalresp(1)> program
 463 * C<YKINFO> - Path to the L<ykinfo(1)> program
 464 * C<YKCHALRESP_FLAGS> - Extra arguments to the B<ykchalresp(1)> program
 465 * C<YKINFO_FLAGS> - Extra arguments to the B<ykinfo(1)> program
 466
 467 B<YubiKey> searches for these programs in the same way perl typically searches for executables (using the
 468 C<PATH> environment variable on many platforms). If the programs aren't installed normally, or if you want to
 469 override the default programs, these environment variables can be used.
 470
 471 =head1 CAVEATS
 472
 473 This doesn't work yet on Windows, probably. The hangup is pretty silly: IPC. Theoretically it would work if
 474 C<run_forked> from L<IPC::Cmd> worked in Windows, but it probably doesn't. I spent a couple hours applying
 475 various quirks to L<IPC::Open3> and L<IPC::Cmd> implementations but never quite got it to worked reliably
 476 without deadlocks. Maybe I'll revisit this later. Hit me up so I know if there's demand.
 477
 478 It would also be possible to implement this is an XS module that incorporated ykcore, using libusb-1 which
 479 would probably make it more portable with Windows. Perhaps if I get around to it.
 480
 481 =cut