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
1 changed files with 392 additions and 0 deletions
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