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