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


line stmt bran cond sub pod time code
1             package Crypt::PKCS11::Easy;
2             $Crypt::PKCS11::Easy::VERSION = '0.180080';
3             # ABSTRACT: Wrapper around Crypt::PKCS11 to make using a HSM not suck
4              
5 1     1   154164 use v5.16.3; # CentOS7
  1         3  
6 1     1   606 use Crypt::PKCS11 qw/:constant_names :constant/;
  1         58125  
  1         1445  
7 1     1   480 use Crypt::PKCS11::Attributes;
  1         180106  
  1         33  
8 1     1   354 use Log::Any '$log';
  1         6496  
  1         5  
9 1     1   1795 use Path::Tiny;
  1         2  
  1         41  
10 1     1   386 use Safe::Isa;
  1         412  
  1         102  
11 1     1   6 use Try::Tiny;
  1         3  
  1         46  
12 1     1   431 use Types::Standard qw/ArrayRef Str/;
  1         64233  
  1         7  
13 1     1   1008 use Types::Path::Tiny 'AbsFile';
  1         18000  
  1         7  
14 1     1   303 use version;
  1         3  
  1         6  
15 1     1   56 use Moo;
  1         2  
  1         7  
16 1     1   848 use namespace::clean;
  1         7447  
  1         5  
17              
18 1     1   7537 use experimental 'smartmatch';
  1         877  
  1         4  
19              
20 1     1   64 use constant MAX_CHUNK_SIZE => 1024;
  1         2  
  1         664  
21              
22              
23             has module => (
24             is => 'ro',
25             required => 1,
26             isa => Str,
27             );
28              
29             has _module => (
30             is => 'ro',
31             lazy => 1,
32             default => sub {
33             my $self = shift;
34              
35             # is module already a Path::Tiny object?
36             return $self->module if $self->module->$_isa('Path::Tiny');
37              
38             # does module look like a path?
39             return path($self->module)->absolute if $self->module =~ m|/|;
40              
41             # TODO care about non-linux?
42             # just a string, lets try to find a module
43             my $module_name = sprintf '%s.so', $self->module;
44             my $full_module_path;
45             for (@{$self->_module_dirs}) {
46             next unless $_->child($module_name)->is_file;
47             $full_module_path = $_->child($module_name);
48             }
49             if (!$full_module_path) {
50             die 'Unable to find a module for ' . $self->module;
51             }
52             return $full_module_path;
53             },
54              
55             isa => AbsFile,
56             );
57              
58              
59             has rw => (is => 'ro', default => 0);
60              
61              
62             has key => (is => 'ro', predicate => 1);
63              
64              
65             has function => (is => 'ro', default => 'sign');
66              
67              
68             has slot => (is => 'lazy');
69              
70              
71             has token => (is => 'ro', predicate => 1);
72              
73              
74             has pin => (is => 'ro', required => 0);
75              
76              
77             has module_dirs => (
78             is => 'ro',
79             lazy => 1,
80             isa => ArrayRef,
81             default => sub {
82             [
83             '/usr/lib64/pkcs11/', '/usr/lib/pkcs11',
84             '/usr/lib/x86_64-linux-gnu/pkcs11/'
85             ];
86             },
87             );
88              
89             has _pkcs11 => (is => 'rwp');
90              
91             has _key => (is => 'lazy');
92              
93             # to keep usage simple, only allowed one session per object
94             has _session => (is => 'lazy', predicate => 1);
95              
96             # TODO allow overriding defaults, possibly using predefined groups of related mechs
97             has _default_mech => (
98             is => 'ro',
99             default => sub {
100             {
101             digest => CKM_SHA_1,
102             encrypt => CKM_RSA_PKCS,
103             sign => CKM_SHA1_RSA_PKCS,
104             verify => CKM_SHA1_RSA_PKCS,
105              
106             };
107             },
108             );
109              
110             has _module_dirs => (
111             is => 'ro',
112             lazy => 1,
113             default => sub {
114             my $self = shift;
115             my @paths;
116             for (@{$self->module_dirs}) {
117             my $path = path($_)->absolute;
118             push @paths, $path if $path->is_dir;
119             }
120             die "No valid module paths found\n" if scalar @paths == 0;
121             return \@paths;
122             },
123             );
124              
125             has _flags => (
126             is => 'ro',
127             lazy => 1,
128             default => sub {
129             {
130             token => [
131             qw/rng write_protected login_required user_pin_initialized
132             restore_key_not_needed clock_on_token protected_authentication_path
133             dual_crypto_operations token_initialized secondary_authentication
134             user_pin_count_low user_pin_final_try user_pin_locked so_pin_count_low
135             user_pin_to_be_changed so_pin_final_try so_pin_locked so_pin_to_be_changed
136             error_state
137             /
138             ],
139             mechanism => [
140             qw/hw encrypt decrypt digest sign sign_recover verify verify_recover generate generate_key_pair wrap unwrap derive extension/
141             ],
142             slot => [qw/token_present removable_device hw_slot/],
143             };
144             },
145             );
146              
147             has [qw/_token_flags _mechanism_flags _slot_flags/] => (is => 'lazy');
148              
149             has _sig_length => (
150             is => 'ro',
151             lazy => 1,
152             default => sub {
153             {
154             1 => 20,
155             224 => 28,
156             256 => 32,
157             384 => 48,
158             512 => 64,
159             };
160             },
161             );
162              
163             sub _build__mechanism_flags {
164 0     0   0 _flags_to_hash($_[0]->_flags->{mechanism});
165             }
166              
167             sub _build__token_flags {
168 0     0   0 _flags_to_hash($_[0]->_flags->{token});
169             }
170              
171             sub _build__slot_flags {
172 0     0   0 _flags_to_hash($_[0]->_flags->{slot});
173             }
174              
175             sub BUILD {
176 4     4 0 182 my $self = shift;
177 4         9 return $self->_set__pkcs11($self->_build__pkcs11);
178             }
179              
180             sub _flags_to_hash {
181 0     0   0 my $flags = shift;
182 1     1   6 no strict 'refs'; ## no critic
  1         15  
  1         1849  
183             my %flag = map {
184 0         0 my $f = 'Crypt::PKCS11::CKF_' . uc($_);
  0         0  
185 0         0 $f->() => $_;
186             } @$flags;
187              
188 0         0 return \%flag;
189             }
190              
191             sub _build__pkcs11 {
192 4     4   6 my $self = shift;
193              
194 4         17 $log->debug('Initialising PKCS#11...');
195              
196             # Create the main PKCS #11 object, load a PKCS #11 provider .so library and initialize the module
197 4         21 my $pkcs11 = Crypt::PKCS11->new;
198              
199 4 50       125 $pkcs11->load($self->_module)
200             or die sprintf "Failed to load PKCS11 module [%s]: %s\n",
201             $self->_module, $pkcs11->errstr;
202              
203 0 0         $pkcs11->Initialize
204             or die sprintf "Failed to initialize PKCS11 module [%s]: %s\n",
205             $self->_module, $pkcs11->errstr;
206              
207 0           $log->debug("Loaded PKCS#11 module: " . $self->_module);
208              
209 0           return $pkcs11;
210             }
211              
212             sub _build__key {
213 0     0     my $self = shift;
214 0 0         if (!$self->has_key) {
215 0           die 'Tried to automagically find a key without a label';
216             }
217              
218 0           $self->login;
219              
220 0           my $tmpl = Crypt::PKCS11::Attributes->new;
221              
222 0           given ($self->function) {
223 0           return $self->get_signing_key($self->key) when 'sign';
224 0           return $self->get_verification_key($self->key) when 'verify';
225 0           return $self->get_encryption_key($self->key) when 'encrypt';
226 0           default {
227 0           die "Unknown key type: " . $self->function;
228             }
229             }
230              
231             }
232              
233             sub _build_slot {
234 0     0     my $self = shift;
235              
236             # if token is set we can try to find a slot that contains that token
237 0 0         if ($self->has_token) {
238 0           my $slot = $self->get_slot(token => $self->token);
239 0           return $slot->{id};
240             }
241              
242 0 0         my $slot_ids = $self->_pkcs11->GetSlotList(1)
243             or die 'Unable to find any available slots: ' . $self->_pkcs11->errstr;
244              
245 0 0         if (scalar @$slot_ids > 1) {
246 0           die 'There is more than one slot available, specify the one to use';
247             }
248              
249 0           return shift @$slot_ids;
250             }
251              
252             sub _build__session {
253 0     0     my $self = shift;
254              
255             # if this isn't called the Luna always gives UNKNOWN_ERROR when trying
256             # to open a session
257 0           $self->_pkcs11->CloseAllSessions($self->slot);
258              
259             # default to a ro session
260 0           my $flags;
261 0 0         if ($self->rw) {
262 0           $log->debug('Opening a RW session');
263 0           $flags = CKF_RW_SESSION | CKF_SERIAL_SESSION;
264             } else {
265 0           $log->debug('Opening a RO session');
266 0           $flags = CKF_SERIAL_SESSION;
267             }
268              
269 0 0         my $session = $self->_pkcs11->OpenSession($self->slot, $flags)
270             or die sprintf 'Error opening session on slot %s: %s', $self->slot,
271             $self->_pkcs11->errstr;
272              
273 0           $log->debug('Session opened on slot ' . $self->slot);
274 0           return $session;
275             }
276              
277             sub _clean_hash_values {
278 0     0     my $h = shift;
279              
280 0           for (keys %$h) {
281              
282 0 0         if ($_ =~ /^(firmware|hardware|library|cryptoki)Version$/) {
283 0           my $v = sprintf '%i.%i', $h->{$_}->{major}, $h->{$_}->{minor};
284 0           $h->{$_} = version->parse($v);
285 0           next;
286             }
287              
288 0 0         next if ref $h->{$_};
289              
290 0           $h->{$_} =~
291             s/\0$//; # safenet cryptoki 2.2 has some null terminated strings
292 0           $h->{$_} =~ s/\s*$//;
293 0 0         delete $h->{$_} if length $h->{$_} == 0;
294             }
295              
296 0           return;
297             }
298              
299              
300             sub get_info {
301 0     0 1   my $self = shift;
302              
303 0 0         my $info = $self->_pkcs11->GetInfo
304             or die 'Could not retrieve HSM info: ' . $self->_pkcs11->errstr;
305              
306             # according to v2.30 there are no flags and this is always 0
307 0           delete $info->{flags};
308 0           _clean_hash_values($info);
309 0           return $info;
310             }
311              
312              
313             sub get_token_info {
314 0     0 1   my ($self, $slot_id) = @_;
315              
316 0 0         my $token = $self->_pkcs11->GetTokenInfo($slot_id)
317             or die "Unable to retrive token info for slot $slot_id: "
318             . $self->_pkcs11->errstr;
319              
320 0           _clean_hash_values($token);
321              
322 0           for my $f (keys %{$self->_token_flags}) {
  0            
323             $token->{flag}->{$self->_token_flags->{$f}} =
324 0 0         ($token->{flags} & $f) ? 1 : 0;
325             }
326              
327 0           delete $token->{flags};
328              
329 0           return $token;
330             }
331              
332              
333             sub get_slot {
334 0     0 1   my ($self, %arg) = @_;
335              
336 0 0 0       unless (defined $arg{id} || defined $arg{token}) {
337 0           die 'Missing id or token';
338             }
339              
340 0           my ($slot, $slot_id);
341              
342 0 0         if (defined $arg{id}) {
    0          
343              
344 0           $log->debug("Retrieving info for slot $arg{id}");
345             $slot = $self->_pkcs11->GetSlotInfo($arg{id})
346 0 0         or die "Unable to retrieve info for slot $arg{id}: "
347             . $self->_pkcs11->errstr;
348 0           $slot_id = $arg{id};
349              
350             } elsif ($arg{token}) {
351              
352 0           $log->debug(
353             "Searching for slot containing token labelled '$arg{token}'");
354 0           my $slots = $self->get_slots(1);
355 0           for (@$slots) {
356 0 0 0       if ($_->{token}->{label} && $arg{token} eq $_->{token}->{label}) {
357 0           return $_;
358              
359             # last;
360             }
361             }
362 0 0         die "Unable to find slot containing token labelled '$arg{token}'"
363             unless $slot;
364             }
365              
366             # strip whitespace padding
367 0           _clean_hash_values($slot);
368              
369 0           $slot->{id} = $slot_id;
370 0           for my $f (keys %{$self->_slot_flags}) {
  0            
371             $slot->{flag}->{$self->_slot_flags->{$f}} =
372 0 0         ($slot->{flags} & $f) ? 1 : 0;
373             }
374              
375 0           delete $slot->{flags};
376              
377 0 0         if ($slot->{flag}->{token_present}) {
378             try {
379 0     0     $slot->{token} = $self->get_token_info($slot_id);
380             }
381             catch {
382             # there is a token present in this slot but details could not be retrieved.
383             # SoftHSM doesn't require an open session to work, but the Safenet Luna does
384             # the 2.20 docs don't show that a session is required...
385 0     0     $log->debug("Failed to access slot, trying to open a session");
386 0           my $session;
387 0 0         if ($self->_has_session) {
388 0           $session = $self->session;
389             } else {
390 0 0         $session =
391             $self->_pkcs11->OpenSession($slot_id, CKF_SERIAL_SESSION)
392             or die "Error opening session on slot $slot_id: "
393             . $self->_pkcs11->errstr;
394             }
395 0           $slot->{token} = $self->get_token_info($slot_id);
396              
397 0           $session->CloseSession;
398 0           };
399             }
400              
401 0           return $slot;
402             }
403              
404              
405             sub get_slots {
406 0     0 1   my ($self, $with_token) = @_;
407              
408 0 0         my $slot_ids = $self->_pkcs11->GetSlotList($with_token)
409             or die 'Unable to find any available slots: ' . $self->_pkcs11->errstr;
410              
411 0           my @slots;
412 0           for my $slot_id (sort @$slot_ids) {
413 0           my $slot = $self->get_slot(id => $slot_id);
414 0           push @slots, $slot;
415             }
416              
417 0           return \@slots;
418             }
419              
420              
421             sub login {
422 0     0 1   my $self = shift;
423              
424 0           my $pin;
425              
426 0           given (ref $self->pin) {
427 0           when ('CODE') {
428 0           $log->debug('Getting PIN from coderef');
429 0           $pin = $self->pin->();
430             }
431 0           when ('Path::Tiny') {
432 0           $log->debug("Reading PIN from file: " . $self->pin);
433 0           $pin = $self->pin->slurp;
434             }
435 0           default { $pin = $self->pin }
  0            
436             }
437              
438 0 0         die 'No PIN/password specified and no way to get one is set' unless $pin;
439              
440 0           chomp $pin;
441              
442 0           $log->debug('Logging in to session');
443 0 0         $self->_session->Login(CKU_USER, $pin)
444             or die "Failed to login: " . $self->_session->errstr;
445              
446 0           return;
447             }
448              
449             sub _get_key {
450 0     0     my ($self, $label, $tmpl) = @_;
451              
452 0           $log->debug("Searching for key with label: $label");
453 0           $tmpl->push(Crypt::PKCS11::Attribute::Label->new->set($label));
454 0           $self->_session->FindObjectsInit($tmpl);
455              
456             # labels are supposed to be unique
457 0 0         my $objects = $self->_session->FindObjects(1)
458             or die "Couldn't find any key matching label $label: "
459             . $self->_session->errstr;
460              
461 0           $self->_session->FindObjectsFinal;
462              
463             # pulObjectCount down in the XS would tell us how many results were returned
464 0 0         if (scalar @$objects == 0) {
465 0           die "Failed to find a key matching label $label";
466             }
467              
468 0           $log->debug("Found key $label");
469 0           return shift @$objects;
470             }
471              
472              
473             sub get_signing_key {
474 0     0 1   my ($self, $label) = @_;
475              
476 0           my $tmpl =
477             Crypt::PKCS11::Attributes->new->push(
478             Crypt::PKCS11::Attribute::Sign->new->set(1),
479             );
480              
481 0           return $self->_get_key($label, $tmpl);
482             }
483              
484              
485             sub get_verification_key {
486 0     0 1   my ($self, $label) = @_;
487              
488 0           my $tmpl =
489             Crypt::PKCS11::Attributes->new->push(
490             Crypt::PKCS11::Attribute::Verify->new->set(1),
491             );
492              
493 0           return $self->_get_key($label, $tmpl);
494             }
495              
496              
497             sub get_encryption_key {
498 0     0 1   my ($self, $label) = @_;
499              
500 0           $log->debug('Looking for an encryption key');
501              
502 0           my $tmpl =
503             Crypt::PKCS11::Attributes->new->push(
504             Crypt::PKCS11::Attribute::Encrypt->new->set(1),
505             );
506              
507 0           return $self->_get_key($label, $tmpl);
508             }
509              
510             sub _get_pss_params {
511 0     0     my ($self, $hash, $hash_number) = @_;
512              
513 0           $log->debug("Finding params for a $hash RSA PSS signature");
514              
515             # comes in bits, need bytes. Instead of simply dividing by 8 we use a mapping
516             # hash to verify that the length is correct
517 0           my $sig_length = $self->_sig_length->{$hash_number};
518 0 0         unless ($sig_length) {
519 0           die
520             'Unsupported hash type: not SHA1/SHA2-224/SHA2-256/SHA2-384/SHA2-512';
521             }
522              
523 0           $log->debug("slen $sig_length");
524              
525 0           my $pss_param = Crypt::PKCS11::CK_RSA_PKCS_PSS_PARAMS->new;
526              
527 1     1   7 no strict 'refs'; ## no critic
  1         2  
  1         209  
528 0           my $hash_const = 'Crypt::PKCS11::CKM_';
529              
530             # SHA1 is a special case
531 0 0         $hash_const .= $hash eq 'SHA1' ? 'SHA_1' : $hash;
532 0           $log->debug("Hash constant: $hash_const");
533              
534 0           my $r = $pss_param->set_hashAlg($hash_const->());
535 0 0         if ($r != CKR_OK) {
536 0           die 'Failed to set hash algorithm for PSS params: '
537             . Crypt::PKCS11::XS::rv2str($r);
538             }
539              
540 0           $r = $pss_param->set_sLen($sig_length);
541 0 0         if ($r != CKR_OK) {
542 0           die 'Failed to set sLen on PSS params: '
543             . Crypt::PKCS11::XS::rv2str($r);
544             }
545              
546 0           my $mgf_const = "Crypt::PKCS11::CKG_MGF1_$hash";
547 0           $log->debug("MGF constant: $mgf_const");
548              
549 0           $r = $pss_param->set_mgf($mgf_const->());
550 0 0         if ($r != CKR_OK) {
551 0           die 'Failed to set MGF on PSS params: '
552             . Crypt::PKCS11::XS::rv2str($r);
553             }
554              
555 0           return $pss_param;
556             }
557              
558             sub _get_oaep_params {
559 0     0     my ($self) = @_;
560              
561             # SHA1 is the only one supported for now as it is the only one supported by
562             # openssl and softhsm2
563             # https://github.com/openssl/openssl/blob/master/crypto/rsa/rsa_oaep.c
564             # https://github.com/pspacek/SoftHSMv2/blob/master/src/lib/SoftHSM.cpp#L10173
565 0           my $hash = 'SHA1';
566              
567 0           $log->debug('Finding params for an RSA OAEP encryption');
568              
569 0           my $oaep_param = Crypt::PKCS11::CK_RSA_PKCS_OAEP_PARAMS->new;
570              
571 1     1   6 no strict 'refs'; ## no critic
  1         2  
  1         279  
572 0           my $hash_const = 'Crypt::PKCS11::CKM_';
573              
574             # SHA1 is a special case
575 0 0         $hash_const .= $hash eq 'SHA1' ? 'SHA_1' : $hash;
576 0           $log->debug("Hash constant: $hash_const");
577              
578 0           my $r = $oaep_param->set_hashAlg($hash_const->());
579 0 0         if ($r != CKR_OK) {
580 0           die 'Failed to set hash algorithm for OAEP params: '
581             . Crypt::PKCS11::XS::rv2str($r);
582             }
583              
584 0           my $mgf_const = "Crypt::PKCS11::CKG_MGF1_$hash";
585 0           $log->debug("MGF constant: $mgf_const");
586              
587 0           $r = $oaep_param->set_mgf($mgf_const->());
588 0 0         if ($r != CKR_OK) {
589 0           die 'Failed to set MGF on OAEP params: '
590             . Crypt::PKCS11::XS::rv2str($r);
591             }
592              
593 0           $oaep_param->set_source(CKZ_DATA_SPECIFIED);
594              
595 0           return $oaep_param;
596             }
597              
598             sub _handle_common_args {
599 0     0     my ($self, $args) = @_;
600              
601 0 0 0       unless (exists $args->{file} || exists $args->{data}) {
602 0           die 'Missing filename or data';
603             }
604              
605             # first, we check if data is coming via a file and read it in
606 0 0         if ($args->{file}) {
607 0           my $file = delete $args->{file};
608              
609             # a filename or a Path::Tiny object
610 0 0         if (!ref $file) {
    0          
611 0           $file = path $file;
612             } elsif (ref $file ne 'Path::Tiny') {
613 0           die "Don't know how to handle a " . ref $file;
614             }
615 0           $args->{data} = $file->slurp_raw;
616             }
617              
618 0 0         return unless exists $args->{mech};
619              
620             # Check if a non-default mechanism is requested
621              
622 0           $args->{mech} =~ s/-/_/g;
623 0           my $const = 'Crypt::PKCS11::CKM_' . $args->{mech};
624 0           $log->debug("Attempting to use mechanism: $const");
625 1     1   6 no strict 'refs'; ## no critic
  1         2  
  1         1230  
626 0           my $mech = Crypt::PKCS11::CK_MECHANISM->new;
627 0           $mech->set_mechanism($const->());
628              
629             # does this mechanism need parameters?
630 0           my $params;
631 0           given ($args->{mech}) {
632 0           when (/^(SHA(\d+))_RSA_PKCS_PSS$/) {
633 0           $params = $self->_get_pss_params($1, $2);
634             }
635 0           when (/^RSA_PKCS_OAEP$/) {
636 0           $params = $self->_get_oaep_params;
637             }
638 0           default { $log->debug('No extra params required for this mech') }
  0            
639             }
640              
641 0 0         if ($params) {
642 0           my $r = $mech->set_pParameter($params->toBytes);
643              
644 0 0         if ($r != CKR_OK) {
645 0           die 'Failed to set params for mechanism: '
646             . Crypt::PKCS11::XS::rv2str($r);
647             }
648             }
649              
650 0           $args->{mech} = $mech;
651              
652 0           return;
653             }
654              
655              
656             sub sign {
657 0     0 1   my ($self, %args) = @_;
658              
659 0           $self->_handle_common_args(\%args);
660              
661 0 0         if (!$args{mech}) {
662 0           $args{mech} = Crypt::PKCS11::CK_MECHANISM->new;
663 0           $args{mech}->set_mechanism($self->_default_mech->{sign});
664             }
665              
666 0           my $data_len = length $args{data};
667 0           $log->debug("Attempting to sign $data_len bytes of data");
668              
669 0 0         $self->_session->SignInit($args{mech}, $self->_key)
670             or die "Failed to init signing: " . $self->_session->errstr;
671              
672 0 0         if ($data_len < MAX_CHUNK_SIZE) {
673             my $sig = $self->_session->Sign($args{data})
674 0 0         or die "Failed to sign: " . $self->_session->errstr;
675 0           return $sig;
676             }
677              
678             # sign data in chunks
679 0           while (length $args{data}) {
680 0           my $chunk = substr $args{data}, 0, MAX_CHUNK_SIZE, q{};
681 0 0         $self->_session->SignUpdate($chunk)
682             or die "Failed to sign: " . $self->_session->errstr;
683             }
684              
685 0 0         my $sig = $self->_session->SignFinal
686             or die "Failed to sign: " . $self->_session->errstr;
687 0           return $sig;
688             }
689              
690              
691             sub sign_and_encode {
692 0     0 1   my $self = shift;
693              
694 0           require MIME::Base64;
695 0           my $sig_encoded = MIME::Base64::encode_base64($self->sign(@_), '');
696              
697 0           my @lines = unpack '(a64)*', $sig_encoded;
698              
699 0           return sprintf "-----BEGIN SIGNATURE-----\n%s\n-----END SIGNATURE-----\n",
700             (join "\n", @lines);
701              
702             }
703              
704              
705             sub verify {
706 0     0 1   my ($self, %args) = @_;
707              
708 0 0         die 'Missing signature' unless $args{sig};
709 0           $self->_handle_common_args(\%args);
710              
711 0 0         if (!$args{mech}) {
712 0           $args{mech} = Crypt::PKCS11::CK_MECHANISM->new;
713 0           $args{mech}->set_mechanism($self->_default_mech->{verify});
714             }
715              
716 0           my $data_len = length $args{data};
717 0           $log->debug("Attempting to verify $data_len bytes of data");
718              
719 0 0         $self->_session->VerifyInit($args{mech}, $self->_key)
720             or die 'Failed to init verify ' . $self->_session->errstr;
721              
722 0 0         if ($data_len < MAX_CHUNK_SIZE) {
723 0           my $v = $self->_session->Verify($args{data}, $args{sig});
724 0 0         $log->info($self->_session->errstr) unless $v;
725 0           return $v;
726             }
727              
728             # verify data in chunks
729 0           while (length $args{data}) {
730 0           my $chunk = substr $args{data}, 0, MAX_CHUNK_SIZE, q{};
731 0 0         $self->_session->VerifyUpdate($chunk)
732             or die "Failed to verify: " . $self->_session->errstr;
733             }
734              
735             my $v = $self->_session->VerifyFinal($args{sig})
736 0 0         or die "Failed to verify: " . $self->_session->errstr;
737              
738 0           return $v;
739             }
740              
741              
742             sub digest {
743 0     0 1   my ($self, %args) = @_;
744              
745 0           $self->_handle_common_args(\%args);
746              
747 0 0         if (!$args{mech}) {
748 0           $args{mech} = Crypt::PKCS11::CK_MECHANISM->new;
749 0           $args{mech}->set_mechanism($self->_default_mech->{digest});
750             }
751              
752             $self->_session->DigestInit($args{mech})
753 0 0         or die 'Failed to init digest ' . $self->_session->errstr;
754              
755 0           my $d = $self->_session->Digest($args{data});
756 0 0         $log->info($self->_session->errstr) unless $d;
757 0           return $d;
758             }
759              
760             # This shouldn't be here, it's not HSM specific.
761             # Also, CPAN must surely have a cert/key loading module
762              
763              
764             sub decode_signature {
765 0     0 1   my ($self, %args) = @_;
766              
767 0           $self->_handle_common_args(\%args);
768              
769 0           require MIME::Base64;
770              
771 0           say $args{data};
772              
773 0           $args{data} =~ /^-----BEGIN SIGNATURE-----(.+)-----END SIGNATURE-----/s;
774 0 0         die 'Unable to find signature in data' unless $1;
775              
776 0           return MIME::Base64::decode_base64($1);
777             }
778              
779              
780             sub get_mechanism_info {
781 0     0 1   my ($self, $mech, $slot_id) = @_;
782              
783 0   0       $slot_id //= $self->slot;
784              
785 0 0         my $mech_info = $self->_pkcs11->GetMechanismInfo($slot_id, $_)
786             or die 'Failed to get mechanism info ' . $self->_pkcs11->errstr;
787              
788 0           for my $f (keys %{$self->_mechanism_flags}) {
  0            
789             $mech_info->{flag}->{$self->_mechanism_flags->{$f}} =
790 0 0         ($mech_info->{flags} & $f) ? 1 : 0;
791             }
792              
793 0           delete $mech_info->{flags};
794              
795 0           return $mech_info;
796             }
797              
798              
799             # TODO might be nice to filter mechanisms by flags, e.g. give me all the mechs
800             # that can be used for singing
801             sub get_mechanisms {
802 0     0 1   my $self = shift;
803 0           my $slot_id = shift;
804              
805 0   0       $slot_id //= $self->slot;
806              
807 0           $log->debug("Fetching mechanisms for slot $slot_id");
808 0 0         my $mech_list = $self->_pkcs11->GetMechanismList($slot_id)
809             or die 'Failed to get mechanisms ' . $self->_pkcs11->errstr;
810              
811             my %mech = map {
812 0 0         my $name = $CKM_NAME{$_} ? $CKM_NAME{$_} : $_;
  0            
813 0           $name => $self->get_mechanism_info($_, $slot_id);
814             } @$mech_list;
815 0           return \%mech;
816             }
817              
818              
819             sub encrypt {
820 0     0 1   my ($self, %args) = @_;
821              
822 0           $self->_handle_common_args(\%args);
823              
824 0 0         if (!$args{mech}) {
825 0           $args{mech} = Crypt::PKCS11::CK_MECHANISM->new;
826 0           $args{mech}->set_mechanism($self->_default_mech->{encrypt});
827             }
828              
829             # TODO check key size and size of data to be encrypted and look up max sizes for mechanism
830             # XXX trying to encrypt data that is too big returns a CKR_GENERAL_ERROR, which is super-unhelpful
831              
832 0 0         $self->_session->EncryptInit($args{mech}, $self->_key)
833             or die "Failed to init encryption: " . $self->_session->errstr;
834              
835             my $encrypted_data = $self->_session->Encrypt($args{data})
836 0 0         or die "Failed to encrypt: " . $self->_session->errstr;
837              
838 0           return $encrypted_data;
839             }
840              
841             1;
842              
843             __END__