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.52 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 = '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 has device          => 0;
 226 has slot            => 1;
 227 has timeout         => 10;
 228 has pre_challenge   => undef;
 229 has post_challenge  => undef;
 230 has ykchalresp      => sub { $ENV{YKCHALRESP} || 'ykchalresp' };
 231 has ykinfo          => sub { $ENV{YKINFO}     || 'ykinfo' };
 232
 233 =method serial
 234
 235 Get the device serial number, as a number, or C<undef> if there is no such device.
 236
 237 =method version
 238
 239 Get the device firmware version (or C<undef>).
 240
 241 =method touch_level
 242
 243 Get the "touch level" value for the device associated with this key (or C<undef>).
 244
 245 =method vendor_id
 246
 247 =method product_id
 248
 249 Get the vendor ID or product ID for the device associated with this key (or C<undef>).
 250
 251 =cut
 252
 253 has serial      => sub { $_[0]->_set_yubikey_info; $_[0]->{serial} };
 254 has version     => sub { $_[0]->_set_yubikey_info; $_[0]->{version} };
 255 has touch_level => sub { $_[0]->_set_yubikey_info; $_[0]->{touch_level} };
 256 has vendor_id   => sub { $_[0]->_set_yubikey_info; $_[0]->{vendor_id} };
 257 has product_id  => sub { $_[0]->_set_yubikey_info; $_[0]->{product_id} };
 258
 259 =method name
 260
 261     $name = $key->name;
 262
 263 Get a human-readable string identifying the YubiKey (or C<undef>).
 264
 265 =cut
 266
 267 sub name {
 268     my $self = shift;
 269     my $name = _product_name($self->vendor_id, $self->product_id // return);
 270     my $serial = $self->serial;
 271     my $version = $self->version || '?';
 272     my $slot = $self->slot;
 273     my $touch = $self->requires_interaction ? ' - Interaction required' : '';
 274     return sprintf('%s v%s [%d] (slot #%d)', $name, $version, $serial, $slot);
 275 }
 276
 277 =method requires_interaction
 278
 279 Get whether or not the key requires interaction (e.g. a touch) to provide a challenge response (or C<undef>).
 280
 281 =cut
 282
 283 sub requires_interaction {
 284     my $self = shift;
 285     my $touch = $self->touch_level // return;
 286     return $touch & $CONFIG_TOUCH[$self->slot];
 287 }
 288
 289 ##############################################################################
 290
 291 ### Call ykinfo to get some information about a YubiKey
 292 sub _get_yubikey_info {
 293     my $self = shift;
 294     my $device = shift;
 295
 296     my $timeout = $self->timeout;
 297     my @cmd = ($self->_program('ykinfo'), "-n$device", qw{-a});
 298
 299     my $r;
 300     my $try = 0;
 301     TRY:
 302     {
 303         $r = $self->_run_ykpers(\@cmd, {
 304             (0 < $timeout ? (timeout => $timeout) : ()),
 305             terminate_on_parent_sudden_death    => 1,
 306         });
 307
 308         my $exit_code = $r->{exit_code};
 309         if ($exit_code != 0) {
 310             my $err = $r->{stderr};
 311             chomp $err;
 312             my $yk_errno = _yk_errno($err);
 313             return if $yk_errno == YK_ENOKEY;
 314             if ($yk_errno == YK_EWOULDBLOCK && ++$try <= $RETRY_COUNT) {
 315                 sleep $RETRY_INTERVAL;
 316                 goto TRY;
 317             }
 318             alert 'Failed to get YubiKey device info: ' . ($err ? $err : 'Something happened'),
 319                 error       => $err,
 320                 yk_errno    => $yk_errno || 0;
 321             return;
 322         }
 323     }
 324
 325     my $out = $r->{stdout};
 326     chomp $out;
 327     if (!$out) {
 328         alert 'Failed to get YubiKey device info: no output';
 329         return;
 330     }
 331
 332     my %info = map { $_ => ($out =~ /^\Q$_\E: (.+)$/m)[0] }
 333         qw(serial version touch_level vendor_id product_id);
 334     $info{vendor_id}    = hex($info{vendor_id})  if defined $info{vendor_id};
 335     $info{product_id}   = hex($info{product_id}) if defined $info{product_id};
 336
 337     return %info;
 338 }
 339
 340 ### Set the YubiKey information as attributes of a Key object
 341 sub _set_yubikey_info {
 342     my $self = shift;
 343     my %info = $self->_get_yubikey_info($self->device);
 344     @$self{keys %info} = values %info;
 345 }
 346
 347 sub _program {
 348     my $self = shift;
 349     my $name = shift;
 350     my @cmd = $self->$name // $name;
 351     my $name_uc = uc($name);
 352     my $flags = $ENV{"${name_uc}_FLAGS"};
 353     push @cmd, split(/\h+/, $flags) if $flags;
 354     return @cmd;
 355 }
 356
 357 sub _run_ykpers {
 358     my $self = shift;
 359     my $ppid = $$;
 360     my $r = eval { run_forked(@_) };
 361     my $err = $@;
 362     if ($$ != $ppid) {
 363         # Work around IPC::Cmd bug where child can return from run_forked.
 364         # https://rt.cpan.org/Public/Bug/Display.html?id=127372
 365         require POSIX;
 366         POSIX::_exit(0);
 367     }
 368     if ($err || ($r->{exit_code} == 0 && $r->{err_msg} eq '' && $r->{stdout} eq '' && $r->{stderr} eq '')) {
 369         $err //= 'No output';
 370         my $prog = $_[0][0];
 371         throw "Failed to run $prog - Make sure you have the YubiKey Personalization Tool (CLI) package installed.\n",
 372             error => $err;
 373     }
 374     return $r;
 375 }
 376
 377 sub _yk_errno {
 378     local $_ = shift or return 0;
 379     return YK_EUSBERR       if $_ =~ YK_EUSBERR;
 380     return YK_EWRONGSIZ     if $_ =~ YK_EWRONGSIZ;
 381     return YK_EWRITEERR     if $_ =~ YK_EWRITEERR;
 382     return YK_ETIMEOUT      if $_ =~ YK_ETIMEOUT;
 383     return YK_ENOKEY        if $_ =~ YK_ENOKEY;
 384     return YK_EFIRMWARE     if $_ =~ YK_EFIRMWARE;
 385     return YK_ENOMEM        if $_ =~ YK_ENOMEM;
 386     return YK_ENOSTATUS     if $_ =~ YK_ENOSTATUS;
 387     return YK_ENOTYETIMPL   if $_ =~ YK_ENOTYETIMPL;
 388     return YK_ECHECKSUM     if $_ =~ YK_ECHECKSUM;
 389     return YK_EWOULDBLOCK   if $_ =~ YK_EWOULDBLOCK;
 390     return YK_EINVALIDCMD   if $_ =~ YK_EINVALIDCMD;
 391     return YK_EMORETHANONE  if $_ =~ YK_EMORETHANONE;
 392     return YK_ENODATA       if $_ =~ YK_ENODATA;
 393     return -1;
 394 }
 395
 396 my %PIDS;
 397 for my $pid (
 398     YUBIKEY_PID, NEO_OTP_PID, NEO_OTP_CCID_PID, NEO_CCID_PID, NEO_U2F_PID, NEO_OTP_U2F_PID, NEO_U2F_CCID_PID,
 399     NEO_OTP_U2F_CCID_PID, YK4_OTP_PID, YK4_U2F_PID, YK4_OTP_U2F_PID, YK4_CCID_PID, YK4_OTP_CCID_PID,
 400     YK4_U2F_CCID_PID, YK4_OTP_U2F_CCID_PID, PLUS_U2F_OTP_PID, ONLYKEY_PID,
 401 ) {
 402     $PIDS{$pid} = $PIDS{0+$pid} = $pid;
 403 }
 404 sub _product_name { $PIDS{$_[1]} // 'Unknown' }
 405
 406 1;
 407 __END__
 408
 409 =head1 SYNOPSIS
 410
 411     use File::KDBX::Key::YubiKey;
 412     use File::KDBX;
 413
 414     my $yubikey = File::KDBX::Key::YubiKey->new(%attributes);
 415
 416     my $kdbx = File::KDBX->load_file('database.kdbx', $yubikey);
 417     # OR
 418     my $kdbx = File::KDBX->load_file('database.kdbx', ['password', $yubikey]);
 419
 420     # Scan for USB YubiKeys:
 421     my ($first_key, @other_keys) = File::KDBX::Key::YubiKey->scan;
 422
 423     my $response = $first_key->challenge('hello');
 424
 425 =head1 DESCRIPTION
 426
 427 A L<File::KDBX::Key::YubiKey> is a type of challenge-response key. This module follows the KeePassXC-style
 428 challenge-response implementation, so this might not work at all with incompatible challenge-response
 429 implementations (e.g. KeeChallenge).
 430
 431 Inherets methods and attributes from L<File::KDBX::Key::ChallengeResponse>.
 432
 433 To use this type of key to secure a L<File::KDBX> database, you also need to install the
 434 L<YubiKey Personalization Tool (CLI)|https://developers.yubico.com/yubikey-personalization/> and configure at
 435 least one of the slots on your YubiKey for HMAC-SHA1 challenge response mode. You can use the YubiKey
 436 Personalization Tool GUI to do this.
 437
 438 See L<https://keepassxc.org/docs/#faq-yubikey-howto> for more information.
 439
 440 =head1 ENVIRONMENT
 441
 442 =for :list
 443 * C<YKCHALRESP> - Path to the L<ykchalresp(1)> program
 444 * C<YKINFO> - Path to the L<ykinfo(1)> program
 445 * C<YKCHALRESP_FLAGS> - Extra arguments to the B<ykchalresp(1)> program
 446 * C<YKINFO_FLAGS> - Extra arguments to the B<ykinfo(1)> program
 447
 448 B<YubiKey> searches for these programs in the same way perl typically searches for executables (using the
 449 C<PATH> environment variable on many platforms). If the programs aren't installed normally, or if you want to
 450 override the default programs, these environment variables can be used.
 451
 452 =head1 CAVEATS
 453
 454 This doesn't work yet on Windows, probably. The hangup is pretty silly: IPC. Theoretically it would work if
 455 C<run_forked> from L<IPC::Cmd> worked in Windows, but it probably doesn't. I spent a couple hours applying
 456 various quirks to L<IPC::Open3> and L<IPC::Cmd> implementations but never quite got it to worked reliably
 457 without deadlocks. Maybe I'll revisit this later. Hit me up so I know if there's demand.
 458
 459 It would also be possible to implement this is an XS module that incorporated ykcore, using libusb-1 which
 460 would probably make it more portable with Windows. Perhaps if I get around to it.
 461
 462 =cut