Crypt/Monkeysphere/MSVA/MarginalUI.pm

   1 #----------------------------------------------------------------------
   2 # Monkeysphere Validation Agent, Perl version
   3 # Marginal User Interface for reasonable prompting
   4 # Copyright © 2010 Daniel Kahn Gillmor <dkg@fifthhorseman.net>,
   5 #                  Matthew James Goins <mjgoins@openflows.com>,
   6 #                  Jameson Graef Rollins <jrollins@finestructure.net>,
   7 #                  Elliot Winard <enw@caveteen.com>
   8 #
   9 # This program is free software: you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation, either version 3 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21 #
  22 #----------------------------------------------------------------------
  23
  24 { package Crypt::Monkeysphere::MSVA::MarginalUI;
  25
  26   use strict;
  27   use warnings;
  28
  29   use Gtk2;
  30   use Crypt::Monkeysphere::MSVA qw( msvalog );
  31
  32   sub ask_the_user {
  33     my $self = shift;
  34     my $gnupg = shift;
  35     my $uid = shift;
  36     my $fprs = shift;
  37     my @subvalid_key_fprs = @{$fprs};
  38
  39     msvalog('debug', "%d subvalid_key_fprs\n", $#subvalid_key_fprs+1);
  40     foreach my $keyfpr (@subvalid_key_fprs) {
  41       my $fprx = sprintf('0x%.40s', $keyfpr->{fpr}->as_hex_string);
  42       msvalog('debug', "checking on %s\n", $fprx);
  43       foreach my $gpgkey ($gnupg->get_public_keys_with_sigs($fprx)) {
  44         msvalog('debug', "found key %.40s\n", $gpgkey->fingerprint->as_hex_string);
  45         # we're going to prompt the user here if we have any
  46         # relevant certifiers:
  47         my @valid_certifiers;
  48         my @marginal_certifiers;
  49
  50         # FIXME: if there are multiple keys in the OpenPGP WoT
  51         # with the same key material and the same User ID
  52         # attached, we'll be throwing multiple prompts per query
  53         # (until the user selects one or cancels them all).
  54         # That's a mess, but i'm not sure what the better thing
  55         # to do is.
  56         foreach my $user_id ($gpgkey->user_ids) {
  57           msvalog('debug', "found EE User ID %s\n", $user_id->as_string);
  58           if ($user_id->as_string eq $uid) {
  59             # get a list of the certifiers of the relevant User ID for the key
  60             foreach my $cert (@{$user_id->signatures}) {
  61               if ($cert->hex_id =~ /^([A-Fa-f0-9]{16})$/) {
  62                 my $certid = $1;
  63                 msvalog('debug', "found certifier 0x%.16s\n", $certid);
  64                 if ($cert->is_valid()) {
  65                   foreach my $certifier ($gnupg->get_public_keys(sprintf('0x%.40s!', $certid))) {
  66                     my $valid_cuid = 0;
  67                     my $marginal = undef;
  68                     foreach my $cuid ($certifier->user_ids) {
  69                       # grab the first full or ultimate user ID on
  70                       # this certifier's key:
  71                       if ($cuid->validity =~ /^[fu]$/) {
  72                         push(@valid_certifiers, { key_id => $cert->hex_id,
  73                                                   user_id => $cuid->as_string,
  74                                                 } );
  75                         $valid_cuid = 1;
  76                         last;
  77                       } elsif ($cuid->validity =~ /^[m]$/) {
  78                         $marginal = { key_id => $cert->hex_id,
  79                                       user_id => $cuid->as_string,
  80                                     };
  81                       }
  82                     }
  83                     push(@marginal_certifiers, $marginal)
  84                       if (! $valid_cuid && defined $marginal);
  85                   }
  86                 }
  87               } else {
  88                 msvalog('error', "certifier ID does not fit expected pattern '%s'\n", $cert->hex_id);
  89               }
  90             }
  91           }
  92           # else ## do we care at all about other User IDs on this key?
  93
  94           # We now know the list of fully/ultimately-valid
  95           # certifiers, and a separate list of marginally-valid
  96           # certifiers.
  97           if ($#valid_certifiers < 0) {
  98             msvalog('info', "No valid certifiers, so no marginal UI\n");
  99           } else {
 100             my $certifier_list = join("\n", map { sprintf("%s [%s]",
 101                                                           $_->{user_id},
 102                                                           $_->{key_id},
 103                                                          ) } @valid_certifiers);
 104             my $msg = sprintf("The matching key for [%s] is not %svalid.
 105
 106 The certificate is certified by:
 107
 108 %s
 109
 110 Would you like to temporarily accept this certificate for this peer?",
 111                               $uid,
 112                               ('m' == $keyfpr->{val} ? 'fully ' : ''),
 113                               $certifier_list,
 114                              );
 115             my $tip = sprintf("Peer: %s
 116 Key fingerprint: 0x%.40s
 117 GnuPG calculated validity: %s",
 118                               $uid,
 119                               $keyfpr->{fpr}->as_hex_string,
 120                               $keyfpr->{val},
 121                              );
 122             # FIXME: what about revoked certifications?
 123             # FIXME: what about expired certifications?
 124             # FIXME: what about certifications ostensibly made in the future?
 125             msvalog('info', "%s\n", $msg);
 126             msvalog('verbose', "%s\n", $tip);
 127             my $resp = prompt($uid, $msg, $tip);
 128             if ($resp) {
 129               return $resp;
 130             }
 131           }
 132           # FIXME: not doing anything with @marginal_certifiers
 133           # -- that'd be yet more queries to gpg :(
 134         }
 135       }
 136     }
 137     return 0;
 138   }
 139
 140   sub prompt {
 141     my $peer = shift;
 142     my $labeltxt = shift;
 143     my $tip = shift;
 144
 145     Gtk2->init();
 146     # create a new dialog with some buttons - one stock, one not.
 147     my $dialog = Gtk2::Dialog->new(sprintf('Monkeysphere validation agent [%s]', $peer),
 148                                     undef,
 149                                     [],
 150                                     'gtk-no' => 'cancel',
 151                                     'gtk-yes' => 'ok');
 152
 153
 154
 155     my $label = Gtk2::Label->new($labeltxt);
 156     # make the text in the dialog box selectable
 157     $label->set('selectable', 1);
 158     $label->show();
 159     my $button = Gtk2::Button->new_with_label($peer);
 160     $button->show();
 161     my $tipshowing = 0;
 162     $button->signal_connect('clicked',
 163                             sub {
 164  # FIXME: for some reason, $label->set_text($labeltxt."\n\n".$tip) throws this error:
 165  # Insecure dependency in eval_sv() while running with -T switch at Crypt/Monkeysphere/MSVA/MarginalUI.pm line 180.
 166  # the workaround here (remove, destroy, re-create) seems to work, though.
 167                               $dialog->get_content_area()->remove($label);
 168                               $label->destroy();
 169                               if ($tipshowing) {
 170                                 $label = Gtk2::Label->new($labeltxt);
 171                               } else {
 172                                 $label = Gtk2::Label->new($tip."\n\n".$labeltxt);
 173                               }
 174                               $tipshowing = ! $tipshowing;
 175                               $label->set('selectable', 1);
 176                               $label->show();
 177                               $dialog->get_content_area()->add($label);
 178                             });
 179
 180     my $tooltips = Gtk2::Tooltips->new();
 181     $tooltips->set_tip($label, $tip);
 182     $dialog->get_content_area()->add($button);
 183     $dialog->get_content_area()->add($label);
 184     my $resp = 0;
 185
 186     my $icon_file = '/usr/share/pixmaps/monkeysphere-icon.png';
 187
 188     $dialog->set_default_icon_from_file($icon_file)
 189       if (-r $icon_file);
 190     $dialog->set_default_response('cancel');
 191     # set initial kbd input focus on "No" also:
 192     ($dialog->get_action_area()->get_children())[1]->grab_focus();
 193
 194     my $response = $dialog->run();
 195     if ($response eq 'ok') {
 196       $resp = 1;
 197     }
 198
 199     # we'll let the fact that the process is about to terminate
 200     # destroy the window.  so lazy!
 201
 202     return $resp;
 203   }
 204
 205   1;
 206 }