r395@erker: lars | 2008-09-18 10:45:17 +0200
separated keyring management from specific mailing list encryption support
This commit is contained in:
parent
e901614035
commit
bc9543d37a
392
Ezmlm/trunk/GpgKeyRing.pm
Normal file
392
Ezmlm/trunk/GpgKeyRing.pm
Normal file
|
|
@ -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 <devel@sumpfralle.de>
|
||||
|
||||
=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
|
||||
|
||||
Loading…
Reference in a new issue