File Coverage

blib/lib/FTN/Crypt.pm
Criterion Covered Total %
statement 131 194 67.5
branch 31 66 46.9
condition 3 9 33.3
subroutine 18 21 85.7
pod 3 3 100.0
total 186 293 63.4


line stmt bran cond sub pod time code
1             # FTN::Crypt - Encryption of the FTN messages
2             #
3             # Copyright (C) 2019 by Petr Antonov
4             #
5             # This library is free software; you can redistribute it and/or modify it
6             # under the same terms as Perl 5.10.0. For more details, see the full text
7             # of the licenses at https://opensource.org/licenses/Artistic-1.0, and
8             # http://www.gnu.org/licenses/gpl-2.0.html.
9             #
10             # This package is provided "as is" and without any express or implied
11             # warranties, including, without limitation, the implied warranties of
12             # merchantability and fitness for a particular purpose.
13             #
14              
15             package FTN::Crypt;
16              
17 2     2   136493 use strict;
  2         13  
  2         57  
18 2     2   11 use warnings;
  2         4  
  2         47  
19 2     2   26 use v5.10.1;
  2         6  
20              
21 2     2   13 use base qw/FTN::Crypt::Error/;
  2         4  
  2         919  
22              
23             #----------------------------------------------------------------------#
24              
25             =head1 NAME
26              
27             FTN::Crypt - Encryption of the FTN messages.
28              
29             =head2 VERSION
30              
31             0.5
32              
33             =cut
34              
35             our $VERSION = '0.5';
36              
37             #----------------------------------------------------------------------#
38              
39             =head1 SYNOPSIS
40              
41             use FTN::Crypt;
42              
43             my $obj = FTN::Crypt->new(
44             Nodelist => 'NODELIST.*',
45             Pointlist => [
46             'pointlist_1.*',
47             'pointlist_2',
48             ],
49             ) or die FTN::Crypt->error;
50            
51             $obj->encrypt_message(
52             Address => $ftn_address,
53             Message => $msg,
54             ) or die $obj->error;
55              
56             =head1 DESCRIPTION
57              
58             The possibility of FTN netmail encryption may be sometimes a useful option.
59             Corresponding nodelist flag was proposed in FSC-0073.
60              
61             Although current FidoNet Policy (version 4.07 dated June 9, 1989) clearly
62             forbids routing of encrypted traffic without the express permission of
63             all the links in the delivery system, it's still possible to deliver such
64             messages directly. And, obviously, such routing may be allowed in FTN
65             networks other than FidoNet.
66              
67             The proposed nodelist userflag is ENCRYPT:[TYPE], where [TYPE] is one of
68             'PGP2', 'PGP5', 'GnuPG'. So encryption-capable node should have something
69             like U,ENCRYPT:PGP5 in his nodelist record.
70              
71             =cut
72              
73             #----------------------------------------------------------------------#
74              
75 2     2   782 use FTN::Crypt::Constants;
  2         5  
  2         55  
76 2     2   877 use FTN::Crypt::Msg;
  2         6  
  2         67  
77 2     2   849 use FTN::Crypt::Nodelist;
  2         4  
  2         83  
78              
79 2     2   1169 use GnuPG::Interface;
  2         702413  
  2         77  
80              
81 2     2   22 use IO::Handle;
  2         4  
  2         75  
82              
83 2     2   872 use PGP::Finger;
  2         2393244  
  2         236  
84              
85 2     2   32 use Try::Tiny;
  2         4  
  2         3994  
86              
87             #----------------------------------------------------------------------#
88              
89             my $DEFAULT_KEYSERVER_URL = 'https://zimmermann.mayfirst.org/pks/lookup';
90              
91             my $GPG2_BVER = '2.1.0';
92              
93             #----------------------------------------------------------------------#
94              
95             =head1 METHODS
96              
97             =cut
98              
99             #----------------------------------------------------------------------#
100              
101             =head2 new()
102              
103             Constructor.
104              
105             =head3 Parameters:
106              
107             =over 4
108              
109             =item * C<Nodelist>: Path to nodelist file(s), either scalar or arrayref. If contains wildcard, file with maximum number in digital extension will be selected.
110              
111             =item * B<Optional> C<Pointlist>: Path to pointlist file(s), either scalar or arrayref. If contains wildcard, file with maximum number in digital extension will be selected.
112              
113             =item * B<Optional> C<Keyserver> Keyserver (defaults to 'https://zimmermann.mayfirst.org/pks/lookup').
114              
115             =item * B<Optional> C<Pubring> Public keyring file.
116              
117             =item * B<Optional> C<Secring> Secret keyring file.
118              
119             =back
120              
121             =head3 Returns:
122              
123             Created object or error in C<FTN::Crypt-E<gt>error>.
124              
125             Sample:
126              
127             my $obj = FTN::Crypt->new(
128             Nodelist => 'NODELIST.*',
129             Pointlist => [
130             'pointlist_1.*',
131             'pointlist_2',
132             ],
133             ) or die FTN::Crypt->error;
134              
135             =cut
136              
137             sub new {
138 1     1 1 14063 my $class = shift;
139 1         8 my (%opts) = @_;
140              
141 1 50       6 unless (%opts) {
142 0         0 $class->set_error('No options specified');
143 0         0 return;
144             }
145              
146             my $self = {
147 1 50       28 keyserver_url => $opts{Keyserver} ? $opts{Keyserver} : $DEFAULT_KEYSERVER_URL,
148             gnupg => GnuPG::Interface->new(),
149             };
150              
151             $self->{nodelist} = FTN::Crypt::Nodelist->new(
152             Nodelist => $opts{Nodelist},
153             Pointlist => $opts{Pointlist},
154 1         3904 );
155 1 50       9 unless ($self->{nodelist}) {
156 0         0 $class->set_error(FTN::Crypt::Nodelist->error);
157 0         0 return;
158             }
159              
160             $self->{gnupg}->options->hash_init(
161 1         25 armor => 1,
162             meta_interactive => 0,
163             );
164              
165 1 50       12314 $self->{gnupg}->options->push_extra_args('--keyring', $opts{Pubring}) if $opts{Pubring};
166 1 50       138 $self->{gnupg}->options->push_extra_args('--secret-keyring', $opts{Secring}) if $opts{Secring};
167 1         66 $self->{gnupg}->options->push_extra_args('--always-trust');
168              
169 1         54 $self = bless $self, $class;
170 1         6 return $self;
171             }
172              
173             #----------------------------------------------------------------------#
174              
175             =head2 encrypt_message()
176              
177             Message encryption.
178              
179             =head3 Parameters:
180              
181             =over 4
182              
183             =item * C<Address>: Recipient's FTN address.
184              
185             =item * C<Message>: FTN message text with kludges.
186              
187             =back
188              
189             =head3 Returns:
190              
191             Encrypted message or error in C<$obj-E<gt>error>.
192              
193             Sample:
194              
195             my $res = $obj->encrypt_message(
196             Address => $ftn_address,
197             Message => $msg,
198             ) or die $obj->error;
199              
200             =cut
201              
202             sub encrypt_message {
203 1     1 1 874 my $self = shift;
204 1         6 my (%opts) = @_;
205              
206             my $msg = FTN::Crypt::Msg->new(
207             Address => $opts{Address},
208             Message => $opts{Message},
209 1         11 );
210 1 50       3 unless ($msg) {
211 0         0 $self->set_error(FTN::Crypt::Msg->error);
212 0         0 return;
213             }
214              
215 1         3 my $res;
216              
217 1         5 my ($addr, $method) = $self->{nodelist}->get_email_addr($msg->get_address);
218 1 50       29 unless ($addr) {
219 0         0 $self->set_error('Encryption-capable address not found', $self->{nodelist}->error);
220 0         0 return;
221             }
222              
223 1         8 my $gnupg_ver = $self->{gnupg}->version;
224 1 50       20905 if ($method eq 'PGP2') {
    50          
225 0 0       0 if (version->parse($gnupg_ver) < version->parse($GPG2_BVER)) {
226 0         0 $self->{gnupg}->options->meta_pgp_2_compatible(1);
227             } else {
228 0         0 $self->set_error("GnuPG is too new (ver. $gnupg_ver), can't ensure required encryption method ($method)");
229 0         0 return;
230             }
231             } elsif ($method eq 'PGP5') {
232 1         72 $self->{gnupg}->options->meta_pgp_5_compatible(1);
233             }
234              
235 1 50 33     138 unless ($self->_lookup_key($addr) || $self->_import_key($addr)) {
236 0         0 $self->set_error("PGP key for $addr not found");
237 0         0 return;
238             }
239            
240 1         26 my $key_id = $self->_select_key($addr);
241 1         21 $self->{gnupg}->options->push_recipients($key_id);
242              
243 1         123 my ($in_fh, $out_fh, $err_fh) = (IO::Handle->new(), IO::Handle->new(),
244             IO::Handle->new());
245              
246 1         121 my $handles = GnuPG::Handles->new(
247             stdin => $in_fh,
248             stdout => $out_fh,
249             stderr => $err_fh,
250             );
251              
252 1         506 my $pid = $self->{gnupg}->encrypt(handles => $handles);
253              
254 1         4540 print $in_fh $msg->get_text;
255 1         19 close $in_fh;
256              
257 1         8108 my $msg_enc = join '', <$out_fh>;
258 1         30 close $out_fh;
259              
260 1         14 close $err_fh;
261            
262 1         20 waitpid $pid, 0;
263              
264 1 50       22 if ($msg_enc) {
265 1 50       21 unless ($msg->set_text($msg_enc)) {
266 0         0 $self->set_error("Can't write message text", $msg->error);
267 0         0 return;
268             }
269 1 50       9 unless ($msg->add_kludge("$FTN::Crypt::Constants::ENC_MESSAGE_KLUDGE: $method")) {
270 0         0 $self->set_error("Can't modify message kludges", $msg->error);
271 0         0 return;
272             }
273            
274 1         10 $res = $msg->get_message;
275 1 50       6 unless ($res) {
276 0         0 $self->set_error("Can't get message", $msg->error);
277 0         0 return;
278             }
279             } else {
280 0         0 $self->set_error('Message enccryption failed');
281 0         0 return;
282             }
283              
284 1         218 return $res;
285             }
286              
287             #----------------------------------------------------------------------#
288              
289             =head2 decrypt_message()
290              
291             Message decryption.
292              
293             =head3 Parameters:
294              
295             =over 4
296              
297             =item * C<Address>: Recipient's FTN address.
298              
299             =item * C<Message>: FTN message text with kludges.
300              
301             =item * C<Passphrase>: Key passphrase.
302              
303             =back
304              
305             =head3 Returns:
306              
307             Decrypted message or error in C<$obj-E<gt>error>.
308              
309             Sample:
310              
311             my $res = $obj->decrypt_message(
312             Address => $ftn_address,
313             Message => $msg,
314             Passphrase => $pass,
315             ) or die $obj->error;
316              
317             =cut
318              
319             sub decrypt_message {
320 1     1 1 1603 my $self = shift;
321 1         15 my (%opts) = @_;
322              
323 1 50       7 unless (%opts) {
324 0         0 $self->set_error('No options specified');
325 0         0 return;
326             }
327 1 50       9 unless (defined $opts{Passphrase}) {
328 0         0 $self->set_error('No passphrase specified');
329 0         0 return;
330             }
331              
332             my $msg = FTN::Crypt::Msg->new(
333             Address => $opts{Address},
334             Message => $opts{Message},
335 1         14 );
336 1 50       15 unless ($msg) {
337 0         0 $self->set_error(FTN::Crypt::Msg->error);
338 0         0 return;
339             }
340              
341 1         7 my $res;
342              
343             my $method_used;
344 1         3 foreach my $c (@{$msg->get_kludges}) {
  1         6  
345 2         5 foreach my $k (@{$c}) {
  2         3  
346 8 100       61 $method_used = $1 if $k =~ /^$FTN::Crypt::Constants::ENC_MESSAGE_KLUDGE:\s+(\w+)$/;
347             }
348             }
349 1 50       4 unless ($method_used) {
350 0         0 $self->set_error('Message seems not to be encrypted');
351 0         0 return;
352             }
353              
354 1         6 my ($addr, $method) = $self->{nodelist}->get_email_addr($msg->get_address);
355 1 50       33 unless ($addr) {
356 0         0 $self->set_error('Encryption-capable address not found', $self->{nodelist}->error);
357 0         0 return;
358             }
359 1 50       3 unless ($method) {
360 0         0 $self->set_error('Encryption method not found', $self->{nodelist}->error);
361 0         0 return;
362             }
363              
364 1 50       5 if ($method ne $method_used) {
365 0         0 $self->set_error("Message is encrypted with $method_used while node uses $method");
366 0         0 return;
367             }
368              
369 1         40 my ($in_fh, $out_fh, $err_fh, $pass_fh) = (IO::Handle->new(),
370             IO::Handle->new(), IO::Handle->new(), IO::Handle->new());
371            
372 1         178 my $handles = GnuPG::Handles->new(
373             stdin => $in_fh,
374             stdout => $out_fh,
375             stderr => $err_fh,
376             passphrase => $pass_fh,
377             );
378              
379 1         645 my $pid = $self->{gnupg}->decrypt(handles => $handles);
380              
381 1         4657 print $pass_fh $opts{Passphrase};
382 1         32 close $pass_fh;
383              
384 1         51 print $in_fh $msg->get_text;
385 1         33 close $in_fh;
386            
387 1         10518 my $msg_dec = join '', <$out_fh>;
388 1         23 close $out_fh;
389              
390 1         17 close $err_fh;
391              
392 1         23 waitpid $pid, 0;
393              
394 1 50       16 if ($msg_dec) {
395 1 50       97 unless ($msg->set_text($msg_dec)) {
396 0         0 $self->set_error("Can't write message text", $msg->error);
397 0         0 return;
398             }
399 1 50       10 unless ($msg->remove_kludge($FTN::Crypt::Constants::ENC_MESSAGE_KLUDGE)) {
400 0         0 $self->set_error("Can't modify message kludges", $msg->error);
401 0         0 return;
402             }
403              
404 1         62 $res = $msg->get_message;
405 1 50       9 unless ($res) {
406 0         0 $self->set_error("Can't get message", $msg->error);
407 0         0 return;
408             }
409             } else {
410 0         0 $self->set_error('Message decryption failed');
411 0         0 return;
412             }
413              
414 1         145 return $res;
415             }
416              
417             #----------------------------------------------------------------------#
418              
419             sub _lookup_key {
420 2     2   18 my $self = shift;
421 2         8 my ($uid) = @_;
422            
423 2         52 my ($out_fh, $err_fh) = (IO::Handle->new(), IO::Handle->new());
424            
425 2         529 my $handles = GnuPG::Handles->new(
426             stdout => $out_fh,
427             stderr => $err_fh,
428             );
429              
430             my $pid = $self->{gnupg}->list_public_keys(
431 2         2274 handles => $handles,
432             command_args => [$uid],
433             );
434              
435 2         41546 my $out = join '', <$out_fh>;
436              
437 2         56 close $out_fh;
438 2         26 close $err_fh;
439              
440 2         56 waitpid $pid, 0;
441              
442 2 50       169 return $out ? 1 : 0;
443             }
444              
445             #----------------------------------------------------------------------#
446              
447             sub _import_key {
448 0     0   0 my ($self, $uid) = @_;
449              
450 0 0       0 return if $self->_lookup_key($uid);
451              
452 0         0 my $res;
453              
454             try {
455             my $finger = PGP::Finger->new(
456             sources => [
457             PGP::Finger::Keyserver->new(
458             url => $self->{keyserver_url},
459 0     0   0 ),
460             # Now there are no PGP-related DNS records in fidonet.net zone
461             #~ PGP::Finger::DNS->new(
462             #~ dnssec => 1,
463             #~ rr_types => ['OPENPGPKEY', 'TYPE61'],
464             #~ ),
465             ],
466             );
467 0         0 $res = $finger->fetch($uid);
468             } catch {
469 0     0   0 return;
470 0         0 };
471              
472 0 0       0 if ($res) {
473 0         0 my ($in_fh, $out_fh, $err_fh) = (IO::Handle->new(),
474             IO::Handle->new(), IO::Handle->new());
475            
476 0         0 my $handles = GnuPG::Handles->new(
477             stdin => $in_fh,
478             stdout => $out_fh,
479             stderr => $err_fh,
480             );
481              
482 0         0 my $pid = $self->{gnupg}->import_keys(handles => $handles);
483              
484 0         0 print $in_fh $res->as_string('armored');
485 0         0 close $in_fh;
486              
487 0         0 close $out_fh;
488 0         0 close $err_fh;
489              
490 0         0 waitpid $pid, 0;
491              
492 0         0 return 1;
493             }
494              
495 0         0 return;
496             }
497              
498             #----------------------------------------------------------------------#
499              
500             sub _select_key {
501 1     1   9 my ($self, $uid) = @_;
502              
503 1 50       11 return unless $self->_lookup_key($uid);
504              
505 1         20 my @keys;
506 1         29 foreach my $key ($self->{gnupg}->get_public_keys($uid)) {
507 1 50 33     174040 push @keys, [$key->creation_date, $key->hex_id]
508             if !$self->_key_is_disabled($key) && $self->_key_can_encrypt($key);
509 1         58 foreach my $subkey (@{$key->subkeys_ref}) {
  1         22  
510 1 50 33     8 push @keys, [$subkey->creation_date, $subkey->hex_id]
511             if !$self->_key_is_disabled($subkey) && $self->_key_can_encrypt($subkey);
512             }
513             }
514              
515 1         9 @keys = map { '0x' . substr $_->[1], -8 }
516 1         71 sort { $b->[0] <=> $a->[0] }
  0         0  
517             @keys;
518            
519 1         4 return $keys[0];
520             }
521              
522             #----------------------------------------------------------------------#
523              
524             sub _key_is_disabled {
525 2     2   7 my ($self, $key) = @_;
526              
527 2         52 return index($key->usage_flags, 'D') != -1;
528             }
529              
530             #----------------------------------------------------------------------#
531              
532             sub _key_can_encrypt {
533 2     2   44 my ($self, $key) = @_;
534              
535 2         34 return index($key->usage_flags, 'E') != -1;
536             }
537              
538             1;
539             __END__
540              
541             =head1 AUTHOR
542              
543             Petr Antonov, E<lt>pietro@cpan.orgE<gt>
544              
545             =head1 COPYRIGHT AND LICENSE
546              
547             Copyright (C) 2019 by Petr Antonov
548              
549             This library is free software; you can redistribute it and/or modify it
550             under the same terms as Perl 5.10.0. For more details, see the full text
551             of the licenses at L<https://opensource.org/licenses/Artistic-1.0>, and
552             L<http://www.gnu.org/licenses/gpl-2.0.html>.
553              
554             This package is provided "as is" and without any express or implied
555             warranties, including, without limitation, the implied warranties of
556             merchantability and fitness for a particular purpose.
557              
558             =head1 INSTALLATION
559              
560             Using C<cpan>:
561              
562             $ cpan FTN::Crypt
563              
564             Manual install:
565              
566             $ perl Makefile.PL
567             $ make
568             $ make test
569             $ make install
570              
571             =head1 REFERENCES
572              
573             =over 4
574              
575             =item 1 L<FidoNet Policy Document Version 4.07|https://www.fidonet.org/policy4.txt>
576              
577             =item 2 L<FTS-5001 - Nodelist flags and userflags|http://ftsc.org/docs/fts-5001.006>
578              
579             =item 3 L<FSC-0073 - Encrypted message identification for FidoNet *Draft I*|http://ftsc.org/docs/fsc-0073.001>
580              
581             =back
582              
583             =cut