From bc9543d37acfe4f7d2bd011b9802b04694e455ee Mon Sep 17 00:00:00 2001 From: lars Date: Thu, 18 Sep 2008 12:03:49 +0000 Subject: [PATCH] r395@erker: lars | 2008-09-18 10:45:17 +0200 separated keyring management from specific mailing list encryption support --- Ezmlm/trunk/GpgKeyRing.pm | 392 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 392 insertions(+) create mode 100644 Ezmlm/trunk/GpgKeyRing.pm diff --git a/Ezmlm/trunk/GpgKeyRing.pm b/Ezmlm/trunk/GpgKeyRing.pm new file mode 100644 index 0000000..77d996a --- /dev/null +++ b/Ezmlm/trunk/GpgKeyRing.pm @@ -0,0 +1,392 @@ +# =========================================================================== +# Gpg.pm +# $Id$ +# +# Object methods for gpg-ezmlm mailing lists +# +# Copyright (C) 2006, Lars Kruse, All Rights Reserved. +# Please send bug reports and comments to devel@sumpfralle.de +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +# +# ========================================================================== + +package Mail::Ezmlm::GpgKeyRing; + +use strict; +use vars qw($GPG_BIN $VERSION @ISA @EXPORT @EXPORT_OK); +use Carp; +use Crypt::GPG; + +$VERSION = '0.1'; + +require 5.005; + +=head1 NAME + +Mail::Ezmlm::GpgKeyRing - Object Methods for gnupg keyring management + +=head1 SYNOPSIS + + use Mail::Ezmlm::GpgKeyRing; + $keyring = new Mail::Ezmlm::GpgKeyRing(DIRNAME); + +The rest is a bit complicated for a Synopsis, see the description. + +=head1 DESCRIPTION + +Mail::Ezmlm::GpgKeyRing is a Perl module that is designed to provide an object +interface to GnuPG keyrings for encrypted mailing lists. + +=cut + +# == Begin site dependant variables == +$GPG_BIN = '/usr/bin/gpg'; # Autoinserted by Makefile.PL + + +# == check the gpg path == +$GPG_BIN = '/usr/local/bin/gpg' + unless (-e "$GPG_BIN"); +$GPG_BIN = '/usr/bin/gpg' + unless (-e "$GPG_BIN"); +$GPG_BIN = '/bin/gpg' + unless (-e "$GPG_BIN"); +$GPG_BIN = '/usr/local/bin/gpg2' + unless (-e "$GPG_BIN"); +$GPG_BIN = '/usr/bin/gpg2' + unless (-e "$GPG_BIN"); +$GPG_BIN = '/bin/gpg2' + unless (-e "$GPG_BIN"); +$GPG_BIN = '/usr/local/bin/gpg' + unless (-e "$GPG_BIN"); +$GPG_BIN = '/bin/gpg' + unless (-e "$GPG_BIN"); + +# == clean up the path for taint checking == +local $ENV{'PATH'} = "/bin"; + +# == Initialiser - Returns a reference to the object == + +=head2 Setting up a new Mail::Ezmlm::GpgKeyRing object: + + use Mail::Ezmlm::GpgKeyRing; + $keyring = new Mail::Ezmlm::GpgKeyRing('/home/user/lists/foolist/.gnupg'); + +new() returns the new instance for success, undefined if there was a problem. + +=cut + +sub new { + my($class, $keyring_dir) = @_; + my $self = {}; + bless $self, ref $class || $class || 'Mail::Ezmlm::GpgKeyRing'; + if ($self->set_location($keyring_dir)) { + return $self; + } else { + return undef; + } +} + + +# == Return the directory of the gnupg keyring == + +=head2 Determining the location of the configured keyring. + + $whichkeyring = $keyring->get_location(); + print $keyring->get_location(); + +=cut + +sub get_location { + my($self) = shift; + return $self->{'KEYRING_DIR'}; +} + + +# == Set the current keyring directory == + +=head2 Changing which keyring the Mail::Ezmlm::GpgKeyRing object points at: + + $keyring->set_location('/home/user/lists/foolist/.gnupg'); + +=cut + +sub set_location { + my($self, $keyring_dir) = @_; + if (-e "$keyring_dir") { + if (-x "$keyring_dir") { + # at least it is a directory - so it looks ok + $self->{'KEYRING_DIR'} = $keyring_dir; + unless ((-e "$keyring_dir/random_seed") + || (-e "$keyring_dir/pubring.gpg")) { + warn "GPG keyring directory seems to be invalid or empty: " + . $keyring_dir; + } + } else { + # it seems to be a file or something else - we complain + warn "GPG keyring location must be a directory: $keyring_dir"; + $self->{'KEYRING_DIR'} = undef; + } + } else { + # probably the keyring directory does not exist, yet + # a warning should not be necessary + $self->{'KEYRING_DIR'} = $keyring_dir; + } + return $self->{'KEYRING_DIR'} +} + + +# == export a key == + +=head2 Export a key: + +You may export public keys of the keyring. + +The key can be identified by its id or other (unique) patterns (like the +gnupg program). + + $keyring->export_key($key_id); + $keyring->export_key($email_address); + +The return value is a string containing the ascii armored key data. + +=cut + +sub export_key { + my ($self, $keyid) = @_; + my $gpg = $self->_get_gpg_object(); + my $gpgoption = "--armor --export $keyid"; + my $gpgcommand = $gpg->gpgbin() . " " . $gpg->gpgopts() . " $gpgoption"; + my $output = `$gpgcommand 2>/dev/null`; + if ($output) { + return $output; + } else { + return undef; + } +} + + +# == import a new key == + +=head2 Import a key: + +You can import public or secret keys into the keyring. + +The key should be ascii armored. + + $keyring->import_key($ascii_armored_key_data); + +=cut + +sub import_key { + my ($self, $key) = @_; + my $gpg = $self->_get_gpg_object(); + if ($gpg->addkey($key)) { + return (0==0); + } else { + return (1==0); + } +} + + +# == delete a key == + +=head2 Delete a key: + +Remove a public key (and the matching secret key if it exists) from the keyring. + +The argument is the id of the key or any other unique pattern. + + $keyring->delete_key($keyid); + +=cut + +sub delete_key { + my ($self, $keyid) = @_; + my $gpg = $self->_get_gpg_object(); + my $fprint = $self->_get_fingerprint($keyid); + return (1==0) unless (defined($fprint)); + my $gpgoption = "--delete-secret-and-public-key $fprint"; + my $gpgcommand = $gpg->gpgbin() . " " . $gpg->gpgopts() . " $gpgoption"; + if (system($gpgcommand)) { + return (1==0); + } else { + return (0==0); + } +} + + +# == generate new private key == + +=head2 Generate a new key: + + $keyring->generate_key($name, $comment, $email_address, $keysize, $expire); + +Refer to the documentation of gnupg for the format of the arguments. + +=cut + +sub generate_private_key { + my ($self, $name, $comment, $email, $keysize, $expire) = @_; + my $gpg = $self->_get_gpg_object(); + my $gpgoption = "--gen-key"; + my $gpgcommand = $gpg->gpgbin() . " " . $gpg->gpgopts() . " $gpgoption"; + my $pid = open(INPUT, "| $gpgcommand"); + print INPUT "Key-Type: DSA\n"; + print INPUT "Key-Length: 1024\n"; + print INPUT "Subkey-Type: ELG-E\n"; + print INPUT "Subkey-Length: $keysize\n"; + print INPUT "Name-Real: $name\n"; + print INPUT "Name-Comment: $comment\n" if ($comment); + print INPUT "Name-Email: $email\n"; + print INPUT "Expire-Date: $expire\n"; + return close INPUT; +} + + +# == get_public_keys == + +=head2 Getting public keys: + +Return an array of key hashes each containing the following elements: + +=over + +=item * +name + +=item * +email + +=item * +id + +=item * +expires + +=back + + $keyring->get_public_keys(); + $keyring->get_secret_keys(); + +=cut + +sub get_public_keys { + my ($self) = @_; + my @keys = $self->_get_keys("pub"); + return @keys; +} + + +# == get_private_keys == +# see above for POD (get_public_keys) +sub get_secret_keys { + my ($self) = @_; + my @keys = $self->_get_keys("sec"); + return @keys; +} + + +############ some internal functions ############## + +# == internal function for creating a gpg object == +sub _get_gpg_object() { + my ($self) = @_; + my $gpg = new Crypt::GPG(); + my $dirname = $self->{'KEYRING_DIR'}; + $gpg->gpgbin($GPG_BIN); + $gpg->gpgopts("--lock-multiple --no-tty --no-secmem-warning --batch --quiet --homedir '$dirname'"); + return $gpg; +} + + +# == internal function to list keys == +sub _get_keys() { + # type can be "pub" or "sec" + my ($self, $keyType) = @_; + my $gpg = $self->_get_gpg_object(); + my ($flag, $gpgoption, @keys, $key); + if ($keyType eq "pub") { + $flag = "pub"; + $gpgoption = "--list-keys"; + } elsif ($keyType eq "sec") { + $flag = "sec"; + $gpgoption = "--list-secret-keys"; + } else { + warn "wrong keyType: $keyType"; + return undef; + } + my $gpgcommand = $gpg->gpgbin() . " " . $gpg->gpgopts() . " --with-colons $gpgoption"; + my @read_keys = grep /^$flag/, `$gpgcommand`; + foreach $key (@read_keys) { + my ($type, $trust, $size, $algorithm, $id, $created, + $expires, $u2, $ownertrust, $uid) = split ":", $key; + # stupid way of "decoding" utf8 (at least it works for ":") + $uid =~ s/\\x3a/:/g; + $uid =~ /^(.*) <([^<]*)>/; + my $name = $1; + my $email = $2; + push @keys, {name => $name, email => $email, id => $id, expires => $expires}; + } + return @keys; +} + + +# == internal function to retrieve the fingerprint of a key == +sub _get_fingerprint() +{ + my ($self, $key_id) = @_; + my $gpg = $self->_get_gpg_object(); + $key_id =~ /^([0-9A-Z]*)$/; + $key_id = $1; + return undef unless ($key_id); + my $gpgoption = "--fingerprint $key_id"; + + my $gpgcommand = $gpg->gpgbin() . " " . $gpg->gpgopts() . " --with-colons $gpgoption"; + + my @fingerprints = grep /^fpr:/, `$gpgcommand`; + if (@fingerprints > 1) { + warn "[Mail::Ezmlm::Gpg] more than one key matched ($key_id)!"; + return undef; + } + return undef if (@fingerprints < 1); + my $fpr = $fingerprints[0]; + $fpr =~ /^fpr:*([0-9A-Z]*):*$/; + $fpr = $1; + return undef unless $1; + return $1; +} + + +=head1 AUTHOR + + Lars Kruse + +=head1 BUGS + + There are no known bugs. + + Please report bugs to the author or use the bug tracking system at + https://systemausfall.org/trac/ezmlm-web. + +=head1 SEE ALSO + + gnupg(7), gpg(1), gpg2(1), Crypt::GPG(3pm) + + https://systemausfall.org/toolforge/ezmlm-web/ + http://www.ezmlm.org/ + +=cut +