File Coverage

blib/lib/Crypt/PKCS11/Easy.pm

Criterion	Covered	Total	%
statement	59	346	17.0
branch	1	136	0.7
condition	0	15	0.0
subroutine	20	50	40.0
pod	16	17	94.1
total	96	564	17.0

package Crypt::PKCS11::Easy;
$Crypt::PKCS11::Easy::VERSION = '0.180080';
# ABSTRACT: Wrapper around Crypt::PKCS11 to make using a HSM not suck

use v5.16.3;    # CentOS7
use Crypt::PKCS11 qw/:constant_names :constant/;
use Crypt::PKCS11::Attributes;
use Log::Any '$log';
use Path::Tiny;
use Safe::Isa;
use Try::Tiny;
use Types::Standard qw/ArrayRef Str/;
use Types::Path::Tiny 'AbsFile';
use version;
use Moo;
use namespace::clean;

use experimental 'smartmatch';

use constant MAX_CHUNK_SIZE => 1024;


has module => (
    is       => 'ro',
    required => 1,
    isa      => Str,
);

has _module => (
    is      => 'ro',
    lazy    => 1,
    default => sub {
        my $self = shift;

        # is module already a Path::Tiny object?
        return $self->module if $self->module->$_isa('Path::Tiny');

        # does module look like a path?
        return path($self->module)->absolute if $self->module =~ m|/|;

        # TODO care about non-linux?
        # just a string, lets try to find a module
        my $module_name = sprintf '%s.so', $self->module;
        my $full_module_path;
        for (@{$self->_module_dirs}) {
            next unless $_->child($module_name)->is_file;
            $full_module_path = $_->child($module_name);
        }
        if (!$full_module_path) {
            die 'Unable to find a module for ' . $self->module;
        }
        return $full_module_path;
    },

    isa => AbsFile,
);


has rw => (is => 'ro', default => 0);


has key => (is => 'ro', predicate => 1);


has function => (is => 'ro', default => 'sign');


has slot => (is => 'lazy');


has token => (is => 'ro', predicate => 1);


has pin => (is => 'ro', required => 0);


has module_dirs => (
    is      => 'ro',
    lazy    => 1,
    isa     => ArrayRef,
    default => sub {
        [
            '/usr/lib64/pkcs11/', '/usr/lib/pkcs11',
            '/usr/lib/x86_64-linux-gnu/pkcs11/'
        ];
    },
);

has _pkcs11 => (is => 'rwp');

has _key => (is => 'lazy');

# to keep usage simple, only allowed one session per object
has _session => (is => 'lazy', predicate => 1);

# TODO allow overriding defaults, possibly using predefined groups of related mechs
has _default_mech => (
    is      => 'ro',
    default => sub {
        {
            digest  => CKM_SHA_1,
            encrypt => CKM_RSA_PKCS,
            sign    => CKM_SHA1_RSA_PKCS,
            verify  => CKM_SHA1_RSA_PKCS,

        };
    },
);

has _module_dirs => (
    is      => 'ro',
    lazy    => 1,
    default => sub {
        my $self = shift;
        my @paths;
        for (@{$self->module_dirs}) {
            my $path = path($_)->absolute;
            push @paths, $path if $path->is_dir;
        }
        die "No valid module paths found\n" if scalar @paths == 0;
        return \@paths;
    },
);

has _flags => (
    is      => 'ro',
    lazy    => 1,
    default => sub {
        {
            token => [
                qw/rng write_protected login_required user_pin_initialized
                  restore_key_not_needed clock_on_token protected_authentication_path
                  dual_crypto_operations token_initialized secondary_authentication
                  user_pin_count_low user_pin_final_try user_pin_locked so_pin_count_low
                  user_pin_to_be_changed so_pin_final_try so_pin_locked so_pin_to_be_changed
                  error_state
                  /
            ],
            mechanism => [
                qw/hw encrypt decrypt digest sign sign_recover verify verify_recover generate generate_key_pair wrap unwrap derive extension/
            ],
            slot => [qw/token_present removable_device hw_slot/],
        };
    },
);

has [qw/_token_flags _mechanism_flags _slot_flags/] => (is => 'lazy');

has _sig_length => (
    is      => 'ro',
    lazy    => 1,
    default => sub {
        {
            1   => 20,
            224 => 28,
            256 => 32,
            384 => 48,
            512 => 64,
        };
    },
);

sub _build__mechanism_flags {
    _flags_to_hash($_[0]->_flags->{mechanism});
}

sub _build__token_flags {
    _flags_to_hash($_[0]->_flags->{token});
}

sub _build__slot_flags {
    _flags_to_hash($_[0]->_flags->{slot});
}

sub BUILD {
    my $self = shift;
    return $self->_set__pkcs11($self->_build__pkcs11);
}

sub _flags_to_hash {
    my $flags = shift;
    no strict 'refs';    ## no critic
    my %flag = map {
        my $f = 'Crypt::PKCS11::CKF_' . uc($_);
        $f->() => $_;
    } @$flags;

    return \%flag;
}

sub _build__pkcs11 {
    my $self = shift;

    $log->debug('Initialising PKCS#11...');

    # Create the main PKCS #11 object, load a PKCS #11 provider .so library and initialize the module
    my $pkcs11 = Crypt::PKCS11->new;

    $pkcs11->load($self->_module)
      or die sprintf "Failed to load PKCS11 module [%s]: %s\n",
      $self->_module, $pkcs11->errstr;

    $pkcs11->Initialize
      or die sprintf "Failed to initialize PKCS11 module [%s]: %s\n",
      $self->_module, $pkcs11->errstr;

    $log->debug("Loaded PKCS#11 module: " . $self->_module);

    return $pkcs11;
}

sub _build__key {
    my $self = shift;
    if (!$self->has_key) {
        die 'Tried to automagically find a key without a label';
    }

    $self->login;

    my $tmpl = Crypt::PKCS11::Attributes->new;

    given ($self->function) {
        return $self->get_signing_key($self->key) when 'sign';
        return $self->get_verification_key($self->key) when 'verify';
        return $self->get_encryption_key($self->key) when 'encrypt';
        default {
            die "Unknown key type: " . $self->function;
        }
    }

}

sub _build_slot {
    my $self = shift;

    # if token is set we can try to find a slot that contains that token
    if ($self->has_token) {
        my $slot = $self->get_slot(token => $self->token);
        return $slot->{id};
    }

    my $slot_ids = $self->_pkcs11->GetSlotList(1)
      or die 'Unable to find any available slots: ' . $self->_pkcs11->errstr;

    if (scalar @$slot_ids > 1) {
        die 'There is more than one slot available, specify the one to use';
    }

    return shift @$slot_ids;
}

sub _build__session {
    my $self = shift;

    # if this isn't called the Luna always gives UNKNOWN_ERROR when trying
    # to open a session
    $self->_pkcs11->CloseAllSessions($self->slot);

    # default to a ro session
    my $flags;
    if ($self->rw) {
        $log->debug('Opening a RW session');
        $flags = CKF_RW_SESSION | CKF_SERIAL_SESSION;
    } else {
        $log->debug('Opening a RO session');
        $flags = CKF_SERIAL_SESSION;
    }

    my $session = $self->_pkcs11->OpenSession($self->slot, $flags)
      or die sprintf 'Error opening session on slot %s: %s', $self->slot,
      $self->_pkcs11->errstr;

    $log->debug('Session opened on slot ' . $self->slot);
    return $session;
}

sub _clean_hash_values {
    my $h = shift;

    for (keys %$h) {

        if ($_ =~ /^(firmware|hardware|library|cryptoki)Version$/) {
            my $v = sprintf '%i.%i', $h->{$_}->{major}, $h->{$_}->{minor};
            $h->{$_} = version->parse($v);
            next;
        }

        next if ref $h->{$_};

        $h->{$_} =~
          s/\0$//;    # safenet cryptoki 2.2 has some null terminated strings
        $h->{$_} =~ s/\s*$//;
        delete $h->{$_} if length $h->{$_} == 0;
    }

    return;
}


sub get_info {
    my $self = shift;

    my $info = $self->_pkcs11->GetInfo
      or die 'Could not retrieve HSM info: ' . $self->_pkcs11->errstr;

    # according to v2.30 there are no flags and this is always 0
    delete $info->{flags};
    _clean_hash_values($info);
    return $info;
}


sub get_token_info {
    my ($self, $slot_id) = @_;

    my $token = $self->_pkcs11->GetTokenInfo($slot_id)
      or die "Unable to retrive token info for slot $slot_id: "
      . $self->_pkcs11->errstr;

    _clean_hash_values($token);

    for my $f (keys %{$self->_token_flags}) {
        $token->{flag}->{$self->_token_flags->{$f}} =
          ($token->{flags} & $f) ? 1 : 0;
    }

    delete $token->{flags};

    return $token;
}


sub get_slot {
    my ($self, %arg) = @_;

    unless (defined $arg{id} || defined $arg{token}) {
        die 'Missing id or token';
    }

    my ($slot, $slot_id);

    if (defined $arg{id}) {

        $log->debug("Retrieving info for slot $arg{id}");
        $slot = $self->_pkcs11->GetSlotInfo($arg{id})
          or die "Unable to retrieve info for slot $arg{id}: "
          . $self->_pkcs11->errstr;
        $slot_id = $arg{id};

    } elsif ($arg{token}) {

        $log->debug(
            "Searching for slot containing token labelled '$arg{token}'");
        my $slots = $self->get_slots(1);
        for (@$slots) {
            if ($_->{token}->{label} && $arg{token} eq $_->{token}->{label}) {
                return $_;

                # last;
            }
        }
        die "Unable to find slot containing token labelled '$arg{token}'"
          unless $slot;
    }

    # strip whitespace padding
    _clean_hash_values($slot);

    $slot->{id} = $slot_id;
    for my $f (keys %{$self->_slot_flags}) {
        $slot->{flag}->{$self->_slot_flags->{$f}} =
          ($slot->{flags} & $f) ? 1 : 0;
    }

    delete $slot->{flags};

    if ($slot->{flag}->{token_present}) {
        try {
            $slot->{token} = $self->get_token_info($slot_id);
        }
        catch {
            # there is a token present in this slot but details could not be retrieved.
            # SoftHSM doesn't require an open session to work, but the Safenet Luna does
            # the 2.20 docs don't show that a session is required...
            $log->debug("Failed to access slot, trying to open a session");
            my $session;
            if ($self->_has_session) {
                $session = $self->session;
            } else {
                $session =
                  $self->_pkcs11->OpenSession($slot_id, CKF_SERIAL_SESSION)
                  or die "Error opening session on slot $slot_id: "
                  . $self->_pkcs11->errstr;
            }
            $slot->{token} = $self->get_token_info($slot_id);

            $session->CloseSession;
        };
    }

    return $slot;
}


sub get_slots {
    my ($self, $with_token) = @_;

    my $slot_ids = $self->_pkcs11->GetSlotList($with_token)
      or die 'Unable to find any available slots: ' . $self->_pkcs11->errstr;

    my @slots;
    for my $slot_id (sort @$slot_ids) {
        my $slot = $self->get_slot(id => $slot_id);
        push @slots, $slot;
    }

    return \@slots;
}


sub login {
    my $self = shift;

    my $pin;

    given (ref $self->pin) {
        when ('CODE') {
            $log->debug('Getting PIN from coderef');
            $pin = $self->pin->();
        }
        when ('Path::Tiny') {
            $log->debug("Reading PIN from file: " . $self->pin);
            $pin = $self->pin->slurp;
        }
        default { $pin = $self->pin }
    }

    die 'No PIN/password specified and no way to get one is set' unless $pin;

    chomp $pin;

    $log->debug('Logging in to session');
    $self->_session->Login(CKU_USER, $pin)
      or die "Failed to login: " . $self->_session->errstr;

    return;
}

sub _get_key {
    my ($self, $label, $tmpl) = @_;

    $log->debug("Searching for key with label: $label");
    $tmpl->push(Crypt::PKCS11::Attribute::Label->new->set($label));
    $self->_session->FindObjectsInit($tmpl);

    # labels are supposed to be unique
    my $objects = $self->_session->FindObjects(1)
      or die "Couldn't find any key matching label $label: "
      . $self->_session->errstr;

    $self->_session->FindObjectsFinal;

    # pulObjectCount down in the XS would tell us how many results were returned
    if (scalar @$objects == 0) {
        die "Failed to find a key matching label $label";
    }

    $log->debug("Found key $label");
    return shift @$objects;
}


sub get_signing_key {
    my ($self, $label) = @_;

    my $tmpl =
      Crypt::PKCS11::Attributes->new->push(
        Crypt::PKCS11::Attribute::Sign->new->set(1),
      );

    return $self->_get_key($label, $tmpl);
}


sub get_verification_key {
    my ($self, $label) = @_;

    my $tmpl =
      Crypt::PKCS11::Attributes->new->push(
        Crypt::PKCS11::Attribute::Verify->new->set(1),
      );

    return $self->_get_key($label, $tmpl);
}


sub get_encryption_key {
    my ($self, $label) = @_;

    $log->debug('Looking for an encryption key');

    my $tmpl =
      Crypt::PKCS11::Attributes->new->push(
        Crypt::PKCS11::Attribute::Encrypt->new->set(1),
      );

    return $self->_get_key($label, $tmpl);
}

sub _get_pss_params {
    my ($self, $hash, $hash_number) = @_;

    $log->debug("Finding params for a $hash RSA PSS signature");

    # comes in bits, need bytes. Instead of simply dividing by 8 we use a mapping
    # hash to verify that the length is correct
    my $sig_length = $self->_sig_length->{$hash_number};
    unless ($sig_length) {
        die
          'Unsupported hash type: not SHA1/SHA2-224/SHA2-256/SHA2-384/SHA2-512';
    }

    $log->debug("slen $sig_length");

    my $pss_param = Crypt::PKCS11::CK_RSA_PKCS_PSS_PARAMS->new;

    no strict 'refs';    ## no critic
    my $hash_const = 'Crypt::PKCS11::CKM_';

    # SHA1 is a special case
    $hash_const .= $hash eq 'SHA1' ? 'SHA_1' : $hash;
    $log->debug("Hash constant: $hash_const");

    my $r = $pss_param->set_hashAlg($hash_const->());
    if ($r != CKR_OK) {
        die 'Failed to set hash algorithm for PSS params: '
          . Crypt::PKCS11::XS::rv2str($r);
    }

    $r = $pss_param->set_sLen($sig_length);
    if ($r != CKR_OK) {
        die 'Failed to set sLen on PSS params: '
          . Crypt::PKCS11::XS::rv2str($r);
    }

    my $mgf_const = "Crypt::PKCS11::CKG_MGF1_$hash";
    $log->debug("MGF constant: $mgf_const");

    $r = $pss_param->set_mgf($mgf_const->());
    if ($r != CKR_OK) {
        die 'Failed to set MGF on PSS params: '
          . Crypt::PKCS11::XS::rv2str($r);
    }

    return $pss_param;
}

sub _get_oaep_params {
    my ($self) = @_;

    # SHA1 is the only one supported for now as it is the only one supported by
    # openssl and softhsm2
    # https://github.com/openssl/openssl/blob/master/crypto/rsa/rsa_oaep.c
    # https://github.com/pspacek/SoftHSMv2/blob/master/src/lib/SoftHSM.cpp#L10173
    my $hash = 'SHA1';

    $log->debug('Finding params for an RSA OAEP encryption');

    my $oaep_param = Crypt::PKCS11::CK_RSA_PKCS_OAEP_PARAMS->new;

    no strict 'refs';    ## no critic
    my $hash_const = 'Crypt::PKCS11::CKM_';

    # SHA1 is a special case
    $hash_const .= $hash eq 'SHA1' ? 'SHA_1' : $hash;
    $log->debug("Hash constant: $hash_const");

    my $r = $oaep_param->set_hashAlg($hash_const->());
    if ($r != CKR_OK) {
        die 'Failed to set hash algorithm for OAEP params: '
          . Crypt::PKCS11::XS::rv2str($r);
    }

    my $mgf_const = "Crypt::PKCS11::CKG_MGF1_$hash";
    $log->debug("MGF constant: $mgf_const");

    $r = $oaep_param->set_mgf($mgf_const->());
    if ($r != CKR_OK) {
        die 'Failed to set MGF on OAEP params: '
          . Crypt::PKCS11::XS::rv2str($r);
    }

    $oaep_param->set_source(CKZ_DATA_SPECIFIED);

    return $oaep_param;
}

sub _handle_common_args {
    my ($self, $args) = @_;

    unless (exists $args->{file} || exists $args->{data}) {
        die 'Missing filename or data';
    }

    # first, we check if data is coming via a file and read it in
    if ($args->{file}) {
        my $file = delete $args->{file};

        # a filename or a Path::Tiny object
        if (!ref $file) {
            $file = path $file;
        } elsif (ref $file ne 'Path::Tiny') {
            die "Don't know how to handle a " . ref $file;
        }
        $args->{data} = $file->slurp_raw;
    }

    return unless exists $args->{mech};

    # Check if a non-default mechanism is requested

    $args->{mech} =~ s/-/_/g;
    my $const = 'Crypt::PKCS11::CKM_' . $args->{mech};
    $log->debug("Attempting to use mechanism: $const");
    no strict 'refs';    ## no critic
    my $mech = Crypt::PKCS11::CK_MECHANISM->new;
    $mech->set_mechanism($const->());

    # does this mechanism need parameters?
    my $params;
    given ($args->{mech}) {
        when (/^(SHA(\d+))_RSA_PKCS_PSS$/) {
            $params = $self->_get_pss_params($1, $2);
        }
        when (/^RSA_PKCS_OAEP$/) {
            $params = $self->_get_oaep_params;
        }
        default { $log->debug('No extra params required for this mech') }
    }

    if ($params) {
        my $r = $mech->set_pParameter($params->toBytes);

        if ($r != CKR_OK) {
            die 'Failed to set params for mechanism: '
              . Crypt::PKCS11::XS::rv2str($r);
        }
    }

    $args->{mech} = $mech;

    return;
}


sub sign {
    my ($self, %args) = @_;

    $self->_handle_common_args(\%args);

    if (!$args{mech}) {
        $args{mech} = Crypt::PKCS11::CK_MECHANISM->new;
        $args{mech}->set_mechanism($self->_default_mech->{sign});
    }

    my $data_len = length $args{data};
    $log->debug("Attempting to sign $data_len bytes of data");

    $self->_session->SignInit($args{mech}, $self->_key)
      or die "Failed to init signing: " . $self->_session->errstr;

    if ($data_len < MAX_CHUNK_SIZE) {
        my $sig = $self->_session->Sign($args{data})
          or die "Failed to sign: " . $self->_session->errstr;
        return $sig;
    }

    # sign data in chunks
    while (length $args{data}) {
        my $chunk = substr $args{data}, 0, MAX_CHUNK_SIZE, q{};
        $self->_session->SignUpdate($chunk)
          or die "Failed to sign: " . $self->_session->errstr;
    }

    my $sig = $self->_session->SignFinal
      or die "Failed to sign: " . $self->_session->errstr;
    return $sig;
}


sub sign_and_encode {
    my $self = shift;

    require MIME::Base64;
    my $sig_encoded = MIME::Base64::encode_base64($self->sign(@_), '');

    my @lines = unpack '(a64)*', $sig_encoded;

    return sprintf "-----BEGIN SIGNATURE-----\n%s\n-----END SIGNATURE-----\n",
      (join "\n", @lines);

}


sub verify {
    my ($self, %args) = @_;

    die 'Missing signature' unless $args{sig};
    $self->_handle_common_args(\%args);

    if (!$args{mech}) {
        $args{mech} = Crypt::PKCS11::CK_MECHANISM->new;
        $args{mech}->set_mechanism($self->_default_mech->{verify});
    }

    my $data_len = length $args{data};
    $log->debug("Attempting to verify $data_len bytes of data");

    $self->_session->VerifyInit($args{mech}, $self->_key)
      or die 'Failed to init verify ' . $self->_session->errstr;

    if ($data_len < MAX_CHUNK_SIZE) {
        my $v = $self->_session->Verify($args{data}, $args{sig});
        $log->info($self->_session->errstr) unless $v;
        return $v;
    }

    # verify data in chunks
    while (length $args{data}) {
        my $chunk = substr $args{data}, 0, MAX_CHUNK_SIZE, q{};
        $self->_session->VerifyUpdate($chunk)
          or die "Failed to verify: " . $self->_session->errstr;
    }

    my $v = $self->_session->VerifyFinal($args{sig})
      or die "Failed to verify: " . $self->_session->errstr;

    return $v;
}


sub digest {
    my ($self, %args) = @_;

    $self->_handle_common_args(\%args);

    if (!$args{mech}) {
        $args{mech} = Crypt::PKCS11::CK_MECHANISM->new;
        $args{mech}->set_mechanism($self->_default_mech->{digest});
    }

    $self->_session->DigestInit($args{mech})
      or die 'Failed to init digest ' . $self->_session->errstr;

    my $d = $self->_session->Digest($args{data});
    $log->info($self->_session->errstr) unless $d;
    return $d;
}

# This shouldn't be here, it's not HSM specific.
# Also, CPAN must surely have a cert/key loading module


sub decode_signature {
    my ($self, %args) = @_;

    $self->_handle_common_args(\%args);

    require MIME::Base64;

    say $args{data};

    $args{data} =~ /^-----BEGIN SIGNATURE-----(.+)-----END SIGNATURE-----/s;
    die 'Unable to find signature in data' unless $1;

    return MIME::Base64::decode_base64($1);
}


sub get_mechanism_info {
    my ($self, $mech, $slot_id) = @_;

    $slot_id //= $self->slot;

    my $mech_info = $self->_pkcs11->GetMechanismInfo($slot_id, $_)
      or die 'Failed to get mechanism info ' . $self->_pkcs11->errstr;

    for my $f (keys %{$self->_mechanism_flags}) {
        $mech_info->{flag}->{$self->_mechanism_flags->{$f}} =
          ($mech_info->{flags} & $f) ? 1 : 0;
    }

    delete $mech_info->{flags};

    return $mech_info;
}


# TODO might be nice to filter mechanisms by flags, e.g. give me all the mechs
# that can be used for singing
sub get_mechanisms {
    my $self    = shift;
    my $slot_id = shift;

    $slot_id //= $self->slot;

    $log->debug("Fetching mechanisms for slot $slot_id");
    my $mech_list = $self->_pkcs11->GetMechanismList($slot_id)
      or die 'Failed to get mechanisms ' . $self->_pkcs11->errstr;

    my %mech = map {
        my $name = $CKM_NAME{$_} ? $CKM_NAME{$_} : $_;
        $name => $self->get_mechanism_info($_, $slot_id);
    } @$mech_list;
    return \%mech;
}


sub encrypt {
    my ($self, %args) = @_;

    $self->_handle_common_args(\%args);

    if (!$args{mech}) {
        $args{mech} = Crypt::PKCS11::CK_MECHANISM->new;
        $args{mech}->set_mechanism($self->_default_mech->{encrypt});
    }

    # TODO check key size and size of data to be encrypted and look up max sizes for mechanism
    # XXX trying to encrypt data that is too big returns a CKR_GENERAL_ERROR, which is super-unhelpful

    $self->_session->EncryptInit($args{mech}, $self->_key)
      or die "Failed to init encryption: " . $self->_session->errstr;

    my $encrypted_data = $self->_session->Encrypt($args{data})
      or die "Failed to encrypt: " . $self->_session->errstr;

    return $encrypted_data;
}

1;

__END__