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