package File::KDBX::Key::YubiKey;
# ABSTRACT: A Yubico challenge-response key

use warnings;
use strict;

use File::KDBX::Constants qw(:yubikey);
use File::KDBX::Error;
use File::KDBX::Util qw(:class :io pad_pkcs7);
use IPC::Cmd 0.52 qw(run_forked);
use Ref::Util qw(is_arrayref);
use Symbol qw(gensym);
use namespace::clean;

extends 'File::KDBX::Key::ChallengeResponse';

our $VERSION = '999.999'; # VERSION

# It can take some time for the USB device to be ready again, so we can retry a few times.
our $RETRY_COUNT    = 5;
our $RETRY_INTERVAL = 0.1;

my @CONFIG_VALID = (0, CONFIG1_VALID, CONFIG2_VALID);
my @CONFIG_TOUCH = (0, CONFIG1_TOUCH, CONFIG2_TOUCH);

sub challenge {
    my $self = shift;
    my $challenge = shift;
    my %args = @_;

    my $device  = $args{device}  // $self->device;
    my $slot    = $args{slot}    // $self->slot;
    my $timeout = $args{timeout} // $self->timeout;
    local $self->{device}   = $device;
    local $self->{slot}     = $slot;
    local $self->{timeout}  = $timeout;

    my $hooks = $challenge ne 'test';
    if ($hooks and my $hook = $self->{pre_challenge}) {
        $hook->($self, $challenge);
    }

    my @cmd = ($self->_program('ykchalresp'), "-n$device", "-$slot", qw{-H -i-}, $timeout == 0 ? '-N' : ());

    my $r;
    my $try = 0;
    TRY:
    {
        $r = $self->_run_ykpers(\@cmd, {
            (0 < $timeout ? (timeout => $timeout) : ()),
            child_stdin                         => pad_pkcs7($challenge, 64),
            terminate_on_parent_sudden_death    => 1,
        });

        if (my $t = $r->{timeout}) {
            throw 'Timed out while waiting for challenge response',
                command     => \@cmd,
                challenge   => $challenge,
                timeout     => $t,
                result      => $r;
        }

        my $exit_code = $r->{exit_code};
        if ($exit_code != 0) {
            my $err = $r->{stderr};
            chomp $err;
            my $yk_errno = _yk_errno($err);
            if ($yk_errno == YK_EUSBERR && $err =~ /resource busy/i && ++$try <= $RETRY_COUNT) {
                sleep $RETRY_INTERVAL;
                goto TRY;
            }
            throw 'Failed to receive challenge response: ' . ($err ? $err : 'Something happened'),
                error       => $err,
                yk_errno    => $yk_errno || 0;
        }
    }

    my $resp = $r->{stdout};
    chomp $resp;
    $resp =~ /^[A-Fa-f0-9]+$/ or throw 'Unexpected response from challenge', response => $resp, result => $r;
    $resp = pack('H*', $resp);

    # HMAC-SHA1 response is only 20 bytes
    substr($resp, 20) = '';

    if ($hooks and my $hook = $self->{post_challenge}) {
        $hook->($self, $challenge, $resp);
    }

    return $resp;
}

=method scan

    @keys = File::KDBX::Key::YubiKey->scan(%options);

Find connected, configured YubiKeys that are capable of responding to a challenge. This can take several
second.

Options:

=for :list
* C<limit> - Scan for only up to this many YubiKeys (default: 4)

Other options are passed as-is as attributes to the key constructors of found keys (if any).

=cut

sub scan {
    my $self = shift;
    my %args = @_;

    my $limit = delete $args{limit} // 4;

    my @keys;
    for (my $device = 0; $device < $limit; ++$device) {
        my %info = $self->_get_yubikey_info($device) or last;

        for (my $slot = 1; $slot <= 2; ++$slot) {
            my $config = $CONFIG_VALID[$slot] // next;
            next unless $info{touch_level} & $config;

            my $key = $self->new(%args, device => $device, slot => $slot, %info);
            if ($info{product_id} <= NEO_OTP_U2F_CCID_PID) {
                # NEO and earlier always require touch, so forego testing
                $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]);
                push @keys, $key;
            }
            else {
                eval { $key->challenge('test', timeout => 0) };
                if (my $err = $@) {
                    my $yk_errno = ref $err && $err->details->{yk_errno} || 0;
                    if ($yk_errno == YK_EWOULDBLOCK) {
                        $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]);
                    }
                    elsif ($yk_errno != 0) {
                        # alert $err;
                        next;
                    }
                }
                push @keys, $key;
            }
        }
    }

    return @keys;
}

=attr device

    $device = $key->device($device);

Get or set the device number, which is the index number starting and incrementing from zero assigned
to the YubiKey device. If there is only one detected YubiKey device, it's number is C<0>.

Defaults to C<0>.

=attr slot

    $slot = $key->slot($slot);

Get or set the slot number, which is a number starting and incrementing from one. A YubiKey can have
multiple slots (often just two) which can be independently configured.

Defaults to C<1>.

=attr timeout

    $timeout = $key->timeout($timeout);

Get or set the timeout, in seconds. If the challenge takes longer than this, the challenge will be
cancelled and an error is thrown.

If the timeout is zero, the challenge is non-blocking; an error is thrown if the challenge would
block. If the timeout is negative, timeout is disabled and the challenge will block forever or until
a response is received.

Defaults to C<0>.

=attr pre_challenge

    $callback = $key->pre_challenge($callback);

Get or set a callback function that will be called immediately before any challenge is issued. This might be
used to prompt the user so they are aware that they are expected to interact with their YubiKey.

    $key->pre_challenge(sub {
        my ($key, $challenge) = @_;

        if ($key->requires_interaction) {
            say 'Please touch your key device to proceed with decrypting your KDBX file.';
        }
        say 'Key: ', $key->name;
        if (0 < $key->timeout) {
            say 'Key access request expires: ' . localtime(time + $key->timeout);
        }
    });

You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping
a KDBX database, the entire load/dump will be aborted.

=attr post_challenge

    $callback = $key->post_challenge($callback);

Get or set a callback function that will be called immediately after a challenge response has been received.

You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping
a KDBX database, the entire load/dump will be aborted.

=attr ykchalresp

    $program = $key->ykchalresp;

Get or set the L<ykchalresp(1)> program name or filepath. Defaults to C<$ENV{YKCHALRESP}> or C<ykchalresp>.

=attr ykinfo

    $program = $key->ykinfo;

Get or set the L<ykinfo(1)> program name or filepath. Defaults to C<$ENV{YKINFO}> or C<ykinfo>.

=cut

has device          => 0;
has slot            => 1;
has timeout         => 10;
has pre_challenge   => undef;
has post_challenge  => undef;
has ykchalresp      => sub { $ENV{YKCHALRESP} || 'ykchalresp' };
has ykinfo          => sub { $ENV{YKINFO}     || 'ykinfo' };

=method serial

Get the device serial number, as a number, or C<undef> if there is no such device.

=method version

Get the device firmware version (or C<undef>).

=method touch_level

Get the "touch level" value for the device associated with this key (or C<undef>).

=method vendor_id

=method product_id

Get the vendor ID or product ID for the device associated with this key (or C<undef>).

=cut

has serial      => sub { $_[0]->_set_yubikey_info; $_[0]->{serial} };
has version     => sub { $_[0]->_set_yubikey_info; $_[0]->{version} };
has touch_level => sub { $_[0]->_set_yubikey_info; $_[0]->{touch_level} };
has vendor_id   => sub { $_[0]->_set_yubikey_info; $_[0]->{vendor_id} };
has product_id  => sub { $_[0]->_set_yubikey_info; $_[0]->{product_id} };

=method name

    $name = $key->name;

Get a human-readable string identifying the YubiKey (or C<undef>).

=cut

sub name {
    my $self = shift;
    my $name = _product_name($self->vendor_id, $self->product_id // return);
    my $serial = $self->serial;
    my $version = $self->version || '?';
    my $slot = $self->slot;
    my $touch = $self->requires_interaction ? ' - Interaction required' : '';
    return sprintf('%s v%s [%d] (slot #%d)', $name, $version, $serial, $slot);
}

=method requires_interaction

Get whether or not the key requires interaction (e.g. a touch) to provide a challenge response (or C<undef>).

=cut

sub requires_interaction {
    my $self = shift;
    my $touch = $self->touch_level // return;
    return $touch & $CONFIG_TOUCH[$self->slot];
}

##############################################################################

### Call ykinfo to get some information about a YubiKey
sub _get_yubikey_info {
    my $self = shift;
    my $device = shift;

    my $timeout = $self->timeout;
    my @cmd = ($self->_program('ykinfo'), "-n$device", qw{-a});

    my $r;
    my $try = 0;
    TRY:
    {
        $r = $self->_run_ykpers(\@cmd, {
            (0 < $timeout ? (timeout => $timeout) : ()),
            terminate_on_parent_sudden_death    => 1,
        });

        my $exit_code = $r->{exit_code};
        if ($exit_code != 0) {
            my $err = $r->{stderr};
            chomp $err;
            my $yk_errno = _yk_errno($err);
            return if $yk_errno == YK_ENOKEY;
            if ($yk_errno == YK_EWOULDBLOCK && ++$try <= $RETRY_COUNT) {
                sleep $RETRY_INTERVAL;
                goto TRY;
            }
            alert 'Failed to get YubiKey device info: ' . ($err ? $err : 'Something happened'),
                error       => $err,
                yk_errno    => $yk_errno || 0;
            return;
        }
    }

    my $out = $r->{stdout};
    chomp $out;
    if (!$out) {
        alert 'Failed to get YubiKey device info: no output';
        return;
    }

    my %info = map { $_ => ($out =~ /^\Q$_\E: (.+)$/m)[0] }
        qw(serial version touch_level vendor_id product_id);
    $info{vendor_id}    = hex($info{vendor_id})  if defined $info{vendor_id};
    $info{product_id}   = hex($info{product_id}) if defined $info{product_id};

    return %info;
}

### Set the YubiKey information as attributes of a Key object
sub _set_yubikey_info {
    my $self = shift;
    my %info = $self->_get_yubikey_info($self->device);
    @$self{keys %info} = values %info;
}

sub _program {
    my $self = shift;
    my $name = shift;
    my @cmd = $self->$name // $name;
    my $name_uc = uc($name);
    my $flags = $ENV{"${name_uc}_FLAGS"};
    push @cmd, split(/\h+/, $flags) if $flags;
    return @cmd;
}

sub _run_ykpers {
    my $self = shift;
    my $ppid = $$;
    my $r = eval { run_forked(@_) };
    my $err = $@;
    if ($$ != $ppid) {
        # Work around IPC::Cmd bug where child can return from run_forked.
        # https://rt.cpan.org/Public/Bug/Display.html?id=127372
        require POSIX;
        POSIX::_exit(0);
    }
    if ($err || ($r->{exit_code} == 0 && $r->{err_msg} eq '' && $r->{stdout} eq '' && $r->{stderr} eq '')) {
        $err //= 'No output';
        my $prog = $_[0][0];
        throw "Failed to run $prog - Make sure you have the YubiKey Personalization Tool (CLI) package installed.\n",
            error => $err;
    }
    return $r;
}

sub _yk_errno {
    local $_ = shift or return 0;
    return YK_EUSBERR       if $_ =~ YK_EUSBERR;
    return YK_EWRONGSIZ     if $_ =~ YK_EWRONGSIZ;
    return YK_EWRITEERR     if $_ =~ YK_EWRITEERR;
    return YK_ETIMEOUT      if $_ =~ YK_ETIMEOUT;
    return YK_ENOKEY        if $_ =~ YK_ENOKEY;
    return YK_EFIRMWARE     if $_ =~ YK_EFIRMWARE;
    return YK_ENOMEM        if $_ =~ YK_ENOMEM;
    return YK_ENOSTATUS     if $_ =~ YK_ENOSTATUS;
    return YK_ENOTYETIMPL   if $_ =~ YK_ENOTYETIMPL;
    return YK_ECHECKSUM     if $_ =~ YK_ECHECKSUM;
    return YK_EWOULDBLOCK   if $_ =~ YK_EWOULDBLOCK;
    return YK_EINVALIDCMD   if $_ =~ YK_EINVALIDCMD;
    return YK_EMORETHANONE  if $_ =~ YK_EMORETHANONE;
    return YK_ENODATA       if $_ =~ YK_ENODATA;
    return -1;
}

my %PIDS;
for my $pid (
    YUBIKEY_PID, NEO_OTP_PID, NEO_OTP_CCID_PID, NEO_CCID_PID, NEO_U2F_PID, NEO_OTP_U2F_PID, NEO_U2F_CCID_PID,
    NEO_OTP_U2F_CCID_PID, YK4_OTP_PID, YK4_U2F_PID, YK4_OTP_U2F_PID, YK4_CCID_PID, YK4_OTP_CCID_PID,
    YK4_U2F_CCID_PID, YK4_OTP_U2F_CCID_PID, PLUS_U2F_OTP_PID, ONLYKEY_PID,
) {
    $PIDS{$pid} = $PIDS{0+$pid} = $pid;
}
sub _product_name { $PIDS{$_[1]} // 'Unknown' }

1;
__END__

=head1 SYNOPSIS

    use File::KDBX::Key::YubiKey;
    use File::KDBX;

    my $yubikey = File::KDBX::Key::YubiKey->new(%attributes);

    my $kdbx = File::KDBX->load_file('database.kdbx', $yubikey);
    # OR
    my $kdbx = File::KDBX->load_file('database.kdbx', ['password', $yubikey]);

    # Scan for USB YubiKeys:
    my ($first_key, @other_keys) = File::KDBX::Key::YubiKey->scan;

    my $response = $first_key->challenge('hello');

=head1 DESCRIPTION

A L<File::KDBX::Key::YubiKey> is a type of challenge-response key. This module follows the KeePassXC-style
challenge-response implementation, so this might not work at all with incompatible challenge-response
implementations (e.g. KeeChallenge).

Inherets methods and attributes from L<File::KDBX::Key::ChallengeResponse>.

To use this type of key to secure a L<File::KDBX> database, you also need to install the
L<YubiKey Personalization Tool (CLI)|https://developers.yubico.com/yubikey-personalization/> and configure at
least one of the slots on your YubiKey for HMAC-SHA1 challenge response mode. You can use the YubiKey
Personalization Tool GUI to do this.

See L<https://keepassxc.org/docs/#faq-yubikey-howto> for more information.

=head1 ENVIRONMENT

=for :list
* C<YKCHALRESP> - Path to the L<ykchalresp(1)> program
* C<YKINFO> - Path to the L<ykinfo(1)> program
* C<YKCHALRESP_FLAGS> - Extra arguments to the B<ykchalresp(1)> program
* C<YKINFO_FLAGS> - Extra arguments to the B<ykinfo(1)> program

B<YubiKey> searches for these programs in the same way perl typically searches for executables (using the
C<PATH> environment variable on many platforms). If the programs aren't installed normally, or if you want to
override the default programs, these environment variables can be used.

=head1 CAVEATS

This doesn't work yet on Windows, probably. The hangup is pretty silly: IPC. Theoretically it would work if
C<run_forked> from L<IPC::Cmd> worked in Windows, but it probably doesn't. I spent a couple hours applying
various quirks to L<IPC::Open3> and L<IPC::Cmd> implementations but never quite got it to worked reliably
without deadlocks. Maybe I'll revisit this later. Hit me up so I know if there's demand.

It would also be possible to implement this is an XS module that incorporated ykcore, using libusb-1 which
would probably make it more portable with Windows. Perhaps if I get around to it.

=cut