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(pad_pkcs7);
  10 use IPC::Open3;
  11 use Scope::Guard;
  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 my @CONFIG_VALID = (0, CONFIG1_VALID, CONFIG2_VALID);
  20 my @CONFIG_TOUCH = (0, CONFIG1_TOUCH, CONFIG2_TOUCH);
  21
  22 sub challenge {
  23     my $self = shift;
  24     my $challenge = shift;
  25     my %args = @_;
  26
  27     my @cleanup;
  28
  29     my $device  = $args{device}  // $self->device;
  30     my $slot    = $args{slot}    // $self->slot;
  31     my $timeout = $args{timeout} // $self->timeout;
  32     local $self->{device}   = $device;
  33     local $self->{slot}     = $slot;
  34     local $self->{timeout}  = $timeout;
  35
  36     my $hooks = $challenge ne 'test';
  37     if ($hooks and my $hook = $self->{pre_challenge}) {
  38         $hook->($self, $challenge);
  39     }
  40
  41     my @cmd = ($self->ykchalresp, "-n$device", "-$slot", qw{-H -i-}, $timeout == 0 ? '-N' : ());
  42     my ($pid, $child_in, $child_out, $child_err) = _run_ykpers(@cmd);
  43     push @cleanup, Scope::Guard->new(sub { kill $pid if defined $pid });
  44
  45     # Set up an alarm [mostly] safely
  46     my $prev_alarm = 0;
  47     local $SIG{ALRM} = sub {
  48         $prev_alarm -= $timeout;
  49         throw 'Timed out while waiting for challenge response',
  50             command     => \@cmd,
  51             challenge   => $challenge,
  52             timeout     => $timeout,
  53     };
  54     $prev_alarm = alarm $timeout if 0 < $timeout;
  55     push @cleanup, Scope::Guard->new(sub { alarm($prev_alarm < 1 ? 1 : $prev_alarm) }) if $prev_alarm;
  56
  57     local $SIG{PIPE} = 'IGNORE';
  58     binmode($child_in);
  59     print $child_in pad_pkcs7($challenge, 64);
  60     close($child_in);
  61
  62     binmode($child_out);
  63     binmode($child_err);
  64     my $resp = do { local $/; <$child_out> };
  65     my $err  = do { local $/; <$child_err> };
  66     chomp($resp, $err);
  67
  68     waitpid($pid, 0);
  69     undef $pid;
  70     my $exit_status = $? >> 8;
  71     alarm 0;
  72
  73     my $yk_errno = _yk_errno($err);
  74     $exit_status == 0 or throw 'Failed to receive challenge response: ' . ($err ? $err : ''),
  75         error       => $err,
  76         yk_errno    => $yk_errno || 0;
  77
  78     $resp =~ /^[A-Fa-f0-9]+$/ or throw 'Unexpected response from challenge', response => $resp;
  79     $resp = pack('H*', $resp);
  80
  81     # HMAC-SHA1 response is only 20 bytes
  82     substr($resp, 20) = '';
  83
  84     if ($hooks and my $hook = $self->{post_challenge}) {
  85         $hook->($self, $challenge, $resp);
  86     }
  87
  88     return $resp;
  89 }
  90
  91 =method scan
  92
  93     @keys = File::KDBX::Key::YubiKey->scan(%options);
  94
  95 Find connected, configured YubiKeys that are capable of responding to a challenge. This can take several
  96 second.
  97
  98 Options:
  99
 100 =for :list
 101 * C<limit> - Scan for only up to this many YubiKeys (default: 4)
 102
 103 Other options are passed as-is as attributes to the key constructors of found keys (if any).
 104
 105 =cut
 106
 107 sub scan {
 108     my $self = shift;
 109     my %args = @_;
 110
 111     my $limit = delete $args{limit} // 4;
 112
 113     my @keys;
 114     for (my $device = 0; $device < $limit; ++$device) {
 115         my %info = $self->_get_yubikey_info($device) or last;
 116
 117         for (my $slot = 1; $slot <= 2; ++$slot) {
 118             my $config = $CONFIG_VALID[$slot] // next;
 119             next unless $info{touch_level} & $config;
 120
 121             my $key = $self->new(%args, device => $device, slot => $slot, %info);
 122             if ($info{product_id} <= NEO_OTP_U2F_CCID_PID) {
 123                 # NEO and earlier always require touch, so forego testing
 124                 $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]);
 125                 push @keys, $key;
 126             }
 127             else {
 128                 eval { $key->challenge('test', timeout => 0) };
 129                 if (my $err = $@) {
 130                     my $yk_errno = ref $err && $err->details->{yk_errno} || 0;
 131                     if ($yk_errno == YK_EWOULDBLOCK) {
 132                         $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]);
 133                     }
 134                     elsif ($yk_errno != 0) {
 135                         # alert $err;
 136                         next;
 137                     }
 138                 }
 139                 push @keys, $key;
 140             }
 141         }
 142     }
 143
 144     return @keys;
 145 }
 146
 147 =attr device
 148
 149     $device = $key->device($device);
 150
 151 Get or set the device number, which is the index number starting and incrementing from zero assigned
 152 to the YubiKey device. If there is only one detected YubiKey device, it's number is C<0>.
 153
 154 Defaults to C<0>.
 155
 156 =attr slot
 157
 158     $slot = $key->slot($slot);
 159
 160 Get or set the slot number, which is a number starting and incrementing from one. A YubiKey can have
 161 multiple slots (often just two) which can be independently configured.
 162
 163 Defaults to C<1>.
 164
 165 =attr timeout
 166
 167     $timeout = $key->timeout($timeout);
 168
 169 Get or set the timeout, in seconds. If the challenge takes longer than this, the challenge will be
 170 cancelled and an error is thrown.
 171
 172 If the timeout is zero, the challenge is non-blocking; an error is thrown if the challenge would
 173 block. If the timeout is negative, timeout is disabled and the challenge will block forever or until
 174 a response is received.
 175
 176 Defaults to C<0>.
 177
 178 =attr pre_challenge
 179
 180     $callback = $key->pre_challenge($callback);
 181
 182 Get or set a callback function that will be called immediately before any challenge is issued. This might be
 183 used to prompt the user so they are aware that they are expected to interact with their YubiKey.
 184
 185     $key->pre_challenge(sub {
 186         my ($key, $challenge) = @_;
 187
 188         if ($key->requires_interaction) {
 189             say 'Please touch your key device to proceed with decrypting your KDBX file.';
 190         }
 191         say 'Key: ', $key->name;
 192         if (0 < $key->timeout) {
 193             say 'Key access request expires: ' . localtime(time + $key->timeout);
 194         }
 195     });
 196
 197 You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping
 198 a KDBX database, the entire load/dump will be aborted.
 199
 200 =attr post_challenge
 201
 202     $callback = $key->post_challenge($callback);
 203
 204 Get or set a callback function that will be called immediately after a challenge response has been received.
 205
 206 You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping
 207 a KDBX database, the entire load/dump will be aborted.
 208
 209 =attr ykchalresp
 210
 211     $program = $key->ykchalresp;
 212
 213 Get or set the L<ykchalresp(1)> program name or filepath. Defaults to C<$ENV{YKCHALRESP}> or C<ykchalresp>.
 214
 215 =attr ykinfo
 216
 217     $program = $key->ykinfo;
 218
 219 Get or set the L<ykinfo(1)> program name or filepath. Defaults to C<$ENV{YKINFO}> or C<ykinfo>.
 220
 221 =cut
 222
 223 my %ATTRS = (
 224     device          => 0,
 225     slot            => 1,
 226     timeout         => 10,
 227     pre_challenge   => undef,
 228     post_challenge  => undef,
 229     ykchalresp      => sub { $ENV{YKCHALRESP} || 'ykchalresp' },
 230     ykinfo          => sub { $ENV{YKINFO} || 'ykinfo' },
 231 );
 232 while (my ($subname, $default) = each %ATTRS) {
 233     no strict 'refs'; ## no critic (ProhibitNoStrict)
 234     *{$subname} = sub {
 235         my $self = shift;
 236         $self->{$subname} = shift if @_;
 237         $self->{$subname} //= (ref $default eq 'CODE') ? $default->($self) : $default;
 238     };
 239 }
 240
 241 my %INFO = (
 242     serial      => undef,
 243     version     => undef,
 244     touch_level => undef,
 245     vendor_id   => undef,
 246     product_id  => undef,
 247 );
 248 while (my ($subname, $default) = each %INFO) {
 249     no strict 'refs'; ## no critic (ProhibitNoStrict)
 250     *{$subname} = sub {
 251         my $self = shift;
 252         $self->{$subname} = shift if @_;
 253         defined $self->{$subname} or $self->_set_yubikey_info;
 254         $self->{$subname} // $default;
 255     };
 256 }
 257
 258 =method serial
 259
 260 Get the device serial number, as a number, or C<undef> if there is no such device.
 261
 262 =method version
 263
 264 Get the device firmware version (or C<undef>).
 265
 266 =method touch_level
 267
 268 Get the "touch level" value for the device associated with this key (or C<undef>).
 269
 270 =method vendor_id
 271
 272 =method product_id
 273
 274 Get the vendor ID or product ID for the device associated with this key (or C<undef>).
 275
 276 =method name
 277
 278     $name = $key->name;
 279
 280 Get a human-readable string identifying the YubiKey (or C<undef>).
 281
 282 =cut
 283
 284 sub name {
 285     my $self = shift;
 286     my $name = _product_name($self->vendor_id, $self->product_id // return);
 287     my $serial = $self->serial;
 288     my $version = $self->version || '?';
 289     my $slot = $self->slot;
 290     my $touch = $self->requires_interaction ? ' - Interaction required' : '';
 291     return sprintf('%s v%s [%d] (slot #%d)', $name, $version, $serial, $slot);
 292 }
 293
 294 =method requires_interaction
 295
 296 Get whether or not the key requires interaction (e.g. a touch) to provide a challenge response (or C<undef>).
 297
 298 =cut
 299
 300 sub requires_interaction {
 301     my $self = shift;
 302     my $touch = $self->touch_level // return;
 303     return $touch & $CONFIG_TOUCH[$self->slot];
 304 }
 305
 306 ##############################################################################
 307
 308 ### Call ykinfo to get some information about a YubiKey
 309 sub _get_yubikey_info {
 310     my $self = shift;
 311     my $device = shift;
 312
 313     my @cmd = ($self->ykinfo, "-n$device", qw{-a});
 314
 315     my $try = 0;
 316     TRY:
 317     my ($pid, $child_in, $child_out, $child_err) = _run_ykpers(@cmd);
 318
 319     close($child_in);
 320
 321     local $SIG{PIPE} = 'IGNORE';
 322     binmode($child_out);
 323     binmode($child_err);
 324     my $out = do { local $/; <$child_out> };
 325     my $err = do { local $/; <$child_err> };
 326     chomp $err;
 327
 328     waitpid($pid, 0);
 329     my $exit_status = $? >> 8;
 330
 331     if ($exit_status != 0) {
 332         my $yk_errno = _yk_errno($err);
 333         return if $yk_errno == YK_ENOKEY;
 334         if ($yk_errno == YK_EWOULDBLOCK && ++$try <= 3) {
 335             sleep 0.1;
 336             goto TRY;
 337         }
 338         alert 'Failed to get YubiKey device info: ' . ($err ? $err : 'Something happened'),
 339             error       => $err,
 340             yk_errno    => $yk_errno || 0;
 341         return;
 342     }
 343
 344     if (!$out) {
 345         alert 'Failed to get YubiKey device info: no output';
 346         return;
 347     }
 348
 349     my %info = map { $_ => ($out =~ /^\Q$_\E: (.+)$/m)[0] }
 350         qw(serial version touch_level vendor_id product_id);
 351     $info{vendor_id}    = hex($info{vendor_id})  if defined $info{vendor_id};
 352     $info{product_id}   = hex($info{product_id}) if defined $info{product_id};
 353
 354     return %info;
 355 }
 356
 357 ### Set the YubiKey information as attributes of a Key object
 358 sub _set_yubikey_info {
 359     my $self = shift;
 360     my %info = $self->_get_yubikey_info($self->device);
 361     @$self{keys %info} = values %info;
 362 }
 363
 364 sub _run_ykpers {
 365     my ($child_err, $child_in, $child_out) = (gensym);
 366     my $pid = eval { open3($child_in, $child_out, $child_err, @_) };
 367     if (my $err = $@) {
 368         throw "Failed to run $_[0] - Make sure you have the YubiKey Personalization Tool (CLI) package installed.\n",
 369             error   => $err;
 370     }
 371     return ($pid, $child_in, $child_out, $child_err);
 372 }
 373
 374 sub _yk_errno {
 375     local $_ = shift or return 0;
 376     return YK_EUSBERR       if $_ =~ YK_EUSBERR;
 377     return YK_EWRONGSIZ     if $_ =~ YK_EWRONGSIZ;
 378     return YK_EWRITEERR     if $_ =~ YK_EWRITEERR;
 379     return YK_ETIMEOUT      if $_ =~ YK_ETIMEOUT;
 380     return YK_ENOKEY        if $_ =~ YK_ENOKEY;
 381     return YK_EFIRMWARE     if $_ =~ YK_EFIRMWARE;
 382     return YK_ENOMEM        if $_ =~ YK_ENOMEM;
 383     return YK_ENOSTATUS     if $_ =~ YK_ENOSTATUS;
 384     return YK_ENOTYETIMPL   if $_ =~ YK_ENOTYETIMPL;
 385     return YK_ECHECKSUM     if $_ =~ YK_ECHECKSUM;
 386     return YK_EWOULDBLOCK   if $_ =~ YK_EWOULDBLOCK;
 387     return YK_EINVALIDCMD   if $_ =~ YK_EINVALIDCMD;
 388     return YK_EMORETHANONE  if $_ =~ YK_EMORETHANONE;
 389     return YK_ENODATA       if $_ =~ YK_ENODATA;
 390     return -1;
 391 }
 392
 393 my %PIDS;
 394 for my $pid (
 395     YUBIKEY_PID, NEO_OTP_PID, NEO_OTP_CCID_PID, NEO_CCID_PID, NEO_U2F_PID, NEO_OTP_U2F_PID, NEO_U2F_CCID_PID,
 396     NEO_OTP_U2F_CCID_PID, YK4_OTP_PID, YK4_U2F_PID, YK4_OTP_U2F_PID, YK4_CCID_PID, YK4_OTP_CCID_PID,
 397     YK4_U2F_CCID_PID, YK4_OTP_U2F_CCID_PID, PLUS_U2F_OTP_PID, ONLYKEY_PID,
 398 ) {
 399     $PIDS{$pid} = $PIDS{0+$pid} = $pid;
 400 }
 401 sub _product_name { $PIDS{$_[1]} // 'Unknown' }
 402
 403 1;
 404 __END__
 405
 406 =head1 SYNOPSIS
 407
 408     use File::KDBX::Key::YubiKey;
 409     use File::KDBX;
 410
 411     my $yubikey = File::KDBX::Key::YubiKey->new(%attributes);
 412
 413     my $kdbx = File::KDBX->load_file('database.kdbx', $yubikey);
 414     # OR
 415     my $kdbx = File::KDBX->load_file('database.kdbx', ['password', $yubikey]);
 416
 417     # Scan for USB YubiKeys:
 418     my ($first_key, @other_keys) = File::KDBX::Key::YubiKey->scan;
 419
 420     my $response = $first_key->challenge('hello');
 421
 422 =head1 DESCRIPTION
 423
 424 A L<File::KDBX::Key::YubiKey> is a type of challenge-response key. This module follows the KeePassXC-style
 425 challenge-response implementation, so this might not work at all with incompatible challenge-response
 426 implementations (e.g. KeeChallenge).
 427
 428 To use this type of key to secure a L<File::KDBX> database, you also need to install the
 429 L<YubiKey Personalization Tool (CLI)|https://developers.yubico.com/yubikey-personalization/> and configure at
 430 least one of the slots on your YubiKey for HMAC-SHA1 challenge response mode. You can use the YubiKey
 431 Personalization Tool GUI to do this.
 432
 433 See L<https://keepassxc.org/docs/#faq-yubikey-howto> for more information.
 434
 435 =head1 ENVIRONMENT
 436
 437 =for :list
 438 * C<YKCHALRESP> - Path to the L<ykchalresp(1)> program
 439 * C<YKINFO> - Path to the L<ykinfo(1)> program
 440
 441 C<YubiKey> searches for these programs in the same way perl typically searches for executables (using the
 442 C<PATH> environment variable on many platforms). If the programs aren't installed normally, or if you want to
 443 override the default programs, these environment variables can be used.
 444
 445 =cut