I found something; looks like it was an an off-by-one. I got
Test::Valgrind to stop complaining about it. The script I originally
wrote (also attached) to add principals doesn't crash anymore on my
system but I still need to try it elsewhere.
I should also note that there were other complaints from valgrind around
the GC of the context object that must have always been there. Fixing
that is a little more involved (and should probably be its own bug).
diff -r d74e15a27d7a Admin.pm
--- a/Admin.pm Mon Oct 15 21:08:05 2012 -0700
+++ b/Admin.pm Mon Jan 28 09:30:55 2013 -0800
@@ -193,7 +193,7 @@
KRB5_KDB_ACCESS_ERROR
);
%EXPORT_TAGS = (constants => \@EXPORT_OK);
-$VERSION = '0.13';
+$VERSION = '0.14';
# Preloaded methods go here.
@@ -513,6 +513,21 @@
Expire time (in seconds since the Epoch) of the principal's password
+=item * db_args [@ARGS]
+
+When called without any C<@ARGS>, returns the list of arguments that
+will be passed into the underlying database, as with C<addprinc -x> in
+C<kadmin>. If C<@ARGS> is non-empty, it will replace any database
+arguments, which will then be returned, like this:
+
+ my @old = $principal->db_args;
+ # -or-
+ my @old = $principal->db_args(@new);
+
+ # The RPC call will ignore the tail data unless
+ # you set this flag:
+ $principal->mask($principal->mask | KADM5_TL_DATA);
+
=back
=head2 Operations
diff -r d74e15a27d7a Admin.xs
--- a/Admin.xs Mon Oct 15 21:08:05 2012 -0700
+++ b/Admin.xs Mon Jan 28 09:30:55 2013 -0800
@@ -30,6 +30,7 @@
#include "perl.h"
#include "XSUB.h"
#include <krb5.h>
+#include <kdb.h>
#include <com_err.h>
#ifdef USE_LOCAL_ADMINH
#include "admin.h"
@@ -2018,6 +2019,107 @@
RETVAL
void
+db_args(princ, ...)
+ Authen::Krb5::Admin::Principal princ
+ PROTOTYPE: $;@
+ PREINIT:
+ krb5_tl_data *tl, *last_tl;
+ krb5_octet **db_args;
+ int i;
+
+ PPCODE:
+ /* arglist will be items - 1, but the last item should be a NULL. */
+ Newxz(db_args, items, krb5_octet *);
+
+ /* pull db args off the stack */
+ /* grab the arg stack */
+ for (i = 1; i < items; i++) {
+ krb5_octet *this_arg;
+ STRLEN length = sv_len(ST(i)) + 1;
+ /* Perl_croak(aTHX_ "%d", length);*/
+ Newxz(this_arg, length, krb5_octet);
+ Copy((krb5_octet *)SvPV(ST(i), length), this_arg, length, krb5_octet);
+ /* db_args[i - 1] = (krb5_octet *)SvPV_nolen(ST(i)); */
+ db_args[i - 1] = this_arg;
+ }
+
+ last_tl = NULL;
+ tl = princ->kadm5_princ.tl_data;
+ while (tl != NULL) {
+ krb5_tl_data *next_tl = tl->tl_data_next;
+
+ /* bail out early for anything but db_args */
+ if (tl->tl_data_type != KRB5_TL_DB_ARGS) {
+ last_tl = tl;
+ tl = next_tl;
+ continue;
+ }
+
+ /* otherwise: */
+
+ /* pinched from kdb5.c */
+ if (((char *) tl->tl_data_contents)[tl->tl_data_length - 1] != '\0') {
+ /* croak */
+ Perl_croak(aTHX_ "Unsafe string in principal tail data");
+ }
+ else {
+ SV * tl_out;
+
+ tl_out = newSVpv((const char *) tl->tl_data_contents, 0);
+ XPUSHs(tl_out);
+
+ /* extend and push the stack with a new mortal SvPV */
+ /* mXPUSHp((char *) tl->tl_data_contents, tl->tl_data_length - 1); */
+ /* only two hard things in computer science: cache
+ expiration, naming things, and off-by-one errors. */
+
+ /* PS that copies the string, right? because i'm about to
+ nuke it. */
+
+ /* we're only doing surgery if there is something to
+ replace these with */
+ if (items > 1) {
+ /* stitch next record to last record if it exists */
+ if (last_tl != NULL) last_tl->tl_data_next = next_tl;
+ /* stitch the next one onto if this is the first */
+ else if (tl == princ->kadm5_princ.tl_data)
+ princ->kadm5_princ.tl_data = next_tl;
+
+ /* poof */
+ free(tl->tl_data_contents);
+ free(tl);
+
+ }
+
+ /* set this either way */
+ tl = next_tl;
+ }
+ }
+
+ /* add new db args to tl_data */
+ if (items > 1) {
+ for (i = 0; i < items - 1; i++) {
+ krb5_tl_data *new_tl;
+
+ new_tl = calloc(1, sizeof(*new_tl));
+ new_tl->tl_data_type = KRB5_TL_DB_ARGS;
+ new_tl->tl_data_length = strlen(db_args[i]) + 1;
+ new_tl->tl_data_contents = db_args[i];
+ new_tl->tl_data_next = NULL;
+
+ /* append to list */
+ if (last_tl != NULL) last_tl->tl_data_next = new_tl;
+ else princ->kadm5_princ.tl_data = new_tl;
+
+ /* either way, it becomes the new tail */
+ last_tl = new_tl;
+ }
+ }
+
+ /* explictly get rid of db_args */
+ Safefree(db_args);
+
+void
DESTROY(princ)
Authen::Krb5::Admin::Principal princ
PREINIT:
diff -r d74e15a27d7a MANIFEST.SKIP
--- a/MANIFEST.SKIP Mon Oct 15 21:08:05 2012 -0700
+++ b/MANIFEST.SKIP Mon Jan 28 09:30:55 2013 -0800
@@ -1,3 +1,4 @@
+^\.hg
^Admin\.bs$
^Admin\.[co]$
^CVS/
diff -r d74e15a27d7a Makefile.PL
--- a/Makefile.PL Mon Oct 15 21:08:05 2012 -0700
+++ b/Makefile.PL Mon Jan 28 09:30:55 2013 -0800
@@ -145,7 +145,7 @@
$commands =~ s/PERL_DL_NONLAZY=1 /$new_vars /;
return exists $ENV{PERL_KADM5_TEST_CACHE}
? $commands
- : "\t$KRB5_BINDIR/kinit -S kadmin/admin -c $test_cache -l 5m "
+ : "\t$KRB5_BINDIR/kinit -S kadmin/admin -c $test_cache -l 50m "
. "$KADM5_PRINCIPAL\n$commands"
;
}
diff -r d74e15a27d7a t/30-addprinc.t
--- a/t/30-addprinc.t Mon Oct 15 21:08:05 2012 -0700
+++ b/t/30-addprinc.t Mon Jan 28 09:30:55 2013 -0800
@@ -31,7 +31,7 @@
use strict;
use Test;
-BEGIN { plan test => 20 }
+BEGIN { plan test => 22 }
use Authen::Krb5;
use Authen::Krb5::Admin qw(:constants);
@@ -50,6 +50,14 @@
my $ap = Authen::Krb5::Admin::Principal->new;
ok $ap;
+my @args = $ap->db_args('derp');
+ok !@args;
+
+@args = $ap->db_args;
+#warn $_ for unpack 'C*', $args[0];
+#warn $args[0];
+ok $args[0] eq "derp";
+
$ap->attributes(KRB5_KDB_DISALLOW_ALL_TIX | KRB5_KDB_DISALLOW_TGT_BASED);
ok $ap->attributes, KRB5_KDB_DISALLOW_ALL_TIX | KRB5_KDB_DISALLOW_TGT_BASED;
ok $ap->mask & KADM5_ATTRIBUTES;
@@ -82,5 +90,6 @@
ok $ap->pw_expiration, 1021908826;
ok $ap->mask & KADM5_PW_EXPIRATION;
-ok $handle->create_principal($ap, join '', map { chr rand(255) + 1 } 1..256)
+# utf8 gets ya
+ok $handle->create_principal($ap, join '', map { chr(rand(127) + 1) } 1..256)
or warn Authen::Krb5::Admin::error;
#!/usr/bin/perl
use strict;
use warnings FATAL => 'all';
package K5LDAP::Admin;
use Moose;
#use MooseX::Attribute::Dependent;
use Moose::Util::TypeConstraints;
use namespace::autoclean;
use DateTime;
use Authen::Krb5;
use Authen::Krb5::Admin qw(KADM5_TL_DATA);
use Authen::SASL;
use Net::LDAP;
use Unicode::Transliterate;
has _context => (
is => 'ro',
isa => 'Authen::Krb5::Context',
default => sub {
# lol i just checked the code and this just initializes a
# global. hope you don't have to run this in threads!
my $x = eval { Authen::Krb5::init_context };
# XXX cargo cult: this is almost certainly a no-op and i'm
# merely assuming that it has to be run after init_context.
Authen::Krb5::init_ets;
# now return it, but not sure why. now that i look at the xs
# code, it doesn't give you an object or anything.
$x;
},
);
# XXX maybe it makes more sense for the constructor to provide an
# explicit principal and then build off that, rather than start with
# the credential cache from the environment?
has cc => (
is => 'ro',
isa => 'Authen::Krb5::Ccache',
# lazy => 0,
default => sub { Authen::Krb5::cc_default },
);
has admin => (
is => 'ro',
isa => 'Authen::Krb5::Admin',
# dependency => All['cc'],
lazy => 1,
default => sub {
my $self = shift;
# $self->_get_kadmin_ticket;
my $p = $self->cc->get_principal;
my $ps = sprintf '%s@%s', join('/', $p->data), $p->realm;
my $a = Authen::Krb5::Admin->init_with_creds($ps, $self->cc)
or die Authen::Krb5::Admin::error;
$a;
},
);
# this is a little confusing because the GSSAPI LDAP connection has
# nothing to do with the kerberos munging i'm doing in here.
has sasl => (
is => 'ro',
isa => 'Authen::SASL',
default => sub { Authen::SASL->new(mechanism => 'GSSAPI') },
);
class_type 'LDAPConnection', { class => 'Net::LDAP' };
coerce 'LDAPConnection', from 'Str', via { Net::LDAP->new(shift) };
has ldap => (
is => 'ro',
isa => 'LDAPConnection',
required => 1,
coerce => 1,
);
sub _get_kadmin_ticket {
my $self = shift;
my $cc = $self->cc;
my $me = $cc->get_principal;
my $now = DateTime->now;
my $cursor = $cc->start_seq_get;
my $refresh = 1;
while (my $cred = $cc->next_cred($cursor)) {
# only helps if the ticket isn't expired
my $end = DateTime->from_epoch(epoch => $cred->endtime);
next unless $end > $now;
my $s = Authen::Krb5::parse_name($cred->server);
next unless defined $s->realm and $s->realm eq $me->realm;
# yoda condition!
$refresh = 0 if 'kadmin/admin' eq join '/', $s->data;
}
$cc->end_seq_get($cursor);
# note that this only works if you clear the DISALLOW_TGT_BASED
# flag on the kadmin/admin principal.
if ($refresh) {
warn 'refreshing';
my $ac = Authen::Krb5::AuthContext->new;
Authen::Krb5::mk_req($ac, Authen::Krb5::AP_OPTS_MUTUAL_REQUIRED,
'kadmin', 'admin', '', $cc)
or die Authen::Krb5::error;
}
}
sub _prune_busted_kadmin {
my $self = shift;
my $cc = $self->cc;
if (my $cursor = $cc->start_seq_get) {
while (my $cred = $cc->next_cred($cursor)) {
my $s = Authen::Krb5::parse_name($cred->server);
# next unless defined $s->realm and $s->realm eq $me->realm;
}
$cc->end_seq_get($cursor);
}
}
sub _new_ctx {
my $self = shift;
my $cc = Authen::Krb5::cc_default;
my $p = $cc->get_principal;
my $ps = sprintf '%s@%s', join('/', $p->data), $p->realm;
my $a = Authen::Krb5::Admin->init_with_creds($ps, $self->cc)
or die Authen::Krb5::Admin::error;
$a;
}
sub add_principal {
my ($self, $name, $pass, $dn) = @_;
my $p = Authen::Krb5::parse_name($name);
my $ap = Authen::Krb5::Admin::Principal->new;
$ap->principal($p);
if ($dn) {
$ap->db_args(qq{dn=$dn});
warn $dn;
# tail data will be ignored otherwise
$ap->mask($ap->mask | KADM5_TL_DATA);
}
my $admin = $self->_new_ctx;
unless ($admin->get_principal($p)) {
$admin->create_principal($ap, $pass)
or die Authen::Krb5::Admin::error;
#$self->admin->create_principal($ap, $pass)
# or die Authen::Krb5::Admin::error;
}
}
sub BUILD {
my $self = shift;
$self->_get_kadmin_ticket;
# now connect to the ldap database
$self->ldap->bind(sasl => $self->sasl);
}
sub DEMOLISH {
# same deal
eval { Authen::Krb5::free_context };
}
__PACKAGE__->meta->make_immutable;
no Moose;
1;
# theoretically we can cut this up
package K5LDAP::Admin::Loader;
use Moose;
use namespace::autoclean;
use Moose::Util::TypeConstraints;
extends 'K5LDAP::Admin';
use Net::LDAP::Entry;
use Text::CSV;
has base => (
is => 'ro',
isa => 'Str',
required => 1,
);
has rdn => (
is => 'ro',
isa => 'Str',
required => 1,
);
has map => (
is => 'ro',
isa => 'HashRef',
required => 1,
);
has delimiter => (
is => 'ro',
isa => 'RegexpRef',
required => 1,
);
has member_types => (
is => 'ro',
isa => 'HashRef',
lazy => 1,
default => sub { {} },
);
has employers => (
is => 'ro',
isa => 'HashRef',
lazy => 1,
default => sub { {} },
);
has affiliations => (
is => 'ro',
isa => 'HashRef',
lazy => 1,
default => sub { {} },
);
class_type 'CSVReader', { class => 'Text::CSV' };
coerce 'CSVReader', from 'HashRef', via { Text::CSV->new(shift) };
has csv => (
is => 'ro',
isa => 'CSVReader',
coerce => 1,
default => sub { Text::CSV->new({ binary => 1 }); },
);
subtype 'PrimaryKey', as 'ArrayRef[Str]';
coerce 'PrimaryKey', from 'Str', via { [shift] };
has pk => (
is => 'ro',
isa => 'PrimaryKey',
coerce => 1,
required => 1,
);
has translit => (
is => 'ro',
isa => 'Unicode::Transliterate',
lazy => 1,
default => sub {
Unicode::Transliterate->new(from => 'Latin', to => 'ASCII') },
);
sub _nonempty ($) {
my $x = shift;
defined $x and $x !~ /^\s*$/;
}
sub run {
my ($self, @files) = @_;
for my $fn (@files) {
open my $fh, '<:utf8', $fn or die $!;
my $cols = $self->csv->getline($fh);
$self->csv->column_names(@$cols);
my %record;
while (my $row = $self->csv->getline_hr($fh)) {
next unless keys %$row;
if (@{$self->pk} == grep { _nonempty $_ } @{$row}{@{$self->pk}}) {
# this will contain stuff if we're more than one
# record in.
$self->add_user(\%record) if keys %record;
# only add nonempty values
%record = map { $_ => $row->{$_} }
grep { _nonempty $row->{$_} } keys %$row;
}
else {
#warn Data::Dumper::Dumper($row);
# turn into arrayref
for my $k (grep { _nonempty $row->{$_} } keys %$row) {
if (defined $record{$k}) {
$record{$k} = [$record{$k}]
unless ref $record{$k} eq 'ARRAY';
}
else {
$record{$k} = [];
}
push @{$record{$k}}, $row->{$k};
}
}
}
# add final one
$self->add_user(\%record);
}
}
sub add_user {
my ($self, $rec) = @_;
my $rdnf = $self->map->{$self->rdn};
$rec->{$rdnf} = $self->translit->process($rec->{$rdnf});
$rec->{$rdnf} =~ s/[^0-9A-Za-z.-]//g;
eval { printf "%s %s\n", $rec->{UID}, $rec->{$rdnf} };
if ($@) {
require Data::Dumper;
warn Data::Dumper::Dumper($rec);
}
# create a DN
my $dn = sprintf '%s=%s,%s', $self->rdn, $rec->{$rdnf}, $self->base;
#warn $dn;
my %map = reverse %{$self->map};
my %attrs = map { $map{$_} => $rec->{$_} }
grep { defined $rec->{$_} } keys %map;
# optionally create predicate groups
# optionally create
# create an LDAP object
my $entry = Net::LDAP::Entry->new
($dn, objectClass => [qw(top OpenLDAPperson posixAccount)],
homeDirectory => '/dev/null',
gidNumber => 100, %attrs);
#$entry->dump(\*STDERR);
# shove the ldap object in the servarr
my $result = $entry->update($self->ldap);
$result->code && warn "failed to add entry: ", $result->error ;
$self->add_principal($rec->{$rdnf}, $rec->{Password}, $dn);
}
__PACKAGE__->meta->make_immutable;
no Moose;
1;
# --------8<------
package main;
# remember the service ticket maps the host to the realm, so you can't
# connect to localhost.
my $loader = K5LDAP::Admin::Loader->new(
ldap => 'deuce',
base => 'ou=IAI,dc=privatealpha,dc=com',
rdn => 'uid',
delimiter => qr/\s*;\s*/,
pk => 'UID',
map => {
# uid => sub { sprintf('member-%05d', shift->{UID}) },
uid => 'Generated Username',
uidNumber => 'UID',
cn => 'Contact Name',
sn => 'Last Name',
gn => 'First Name',
o => 'Organization 1',
title => 'Title',
mail => 'Email',
street => 'Street Address',
l => 'City',
st => 'State (US, Canada & Australia)',
postalCode => 'Zip',
},
);
$loader->run(@ARGV);
# predicate groups:
# list me in directory
# active volunteer
# list me in geolocate
# subscribe to member list
# subscribe to newsletter
# groups:
# "Member Group"
# "IAI Initiative Activity"
# "IAI Volunteer Roles"
