### Local Variables: ***
### mode:perl ***
### comment-column:0 ***
### comment-start: "### " ***
### comment-end: "***" ***
### End: ***
#
# ****************DO NOT MOVE OR CHANGE LINES ABOVE THIS*********************
#
# The first set of lines runs perl from any shell. The second set of lines
# identifies the rest of the file as PERL for EMACS autoformatting.
# See end of copyright for more information.
#
#
# -------------------------------------------------------------------
# X-BONE
#
# http://www.isi.edu/xbone
# USC Information Sciences Institute (USC/ISI)
# Marina del Rey, California 90292, USA
# Copyright (c) 1998-2005
#
# -------------------------------------------------------------------
#
# Copyright (c) 1998-2005 by the University of Southern California.
# All rights reserved.
#
# Permission to use, copy, modify, and distribute this software and
# its documentation in source and binary forms for non-commercial
# purposes and without fee is hereby granted, provided that the above
# copyright notice appear in all copies and that both the copyright
# notice and this permission notice appear in supporting
# documentation, and that any documentation, advertising materials,
# and other materials related to such distribution and use acknowledge
# that the software was developed by the University of Southern
# California, Information Sciences Institute. The name of the
# University may not be used to endorse or promote products derived
# from this software without specific prior written permission.
#
# THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT
# THE SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE. THIS SOFTWARE IS
# PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES,
# INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# Other copyrights might apply to parts of this software and are so
# noted when applicable.
#
# -------------------------------------------------------------------
#
# Effort partly sponsored by the Defense Advanced Research Projects
# Agency (DARPA) and Air Force Research Laboratory, Air Force Materiel
# Command, USAF, under agreement numbers F30602-98-1-0200 (X-Bone) and
# F30602-01-2-0529 (DynaBone). The views and conclusions contained
# herein are those of the authors and should not be interpreted as
# necessarily representing the official policies or endorsements,
# either expressed or implied, of the Defense Advanced Research
# Projects Agency (DARPA), the Air Force Research Laboratory, or the
# U.S. Government.
#
# This work was partly supported by the NSF STI-XTEND (ANI-0230789)
# and NETFS (ANI-0129689) projects. Any opinions, findings, and
# conclusions or recommendations expressed in this material are those
# of the authors and do not necessarily reflect the views of the
# National Science Foundation.
#
# --------------------------------------------------------------------------
# $RCSfile: XB_LDAP.pm,v $
#
# $Revision: 1.14 $
# $Author: pingali $
# $Date: 2005/04/10 06:45:03 $
# $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Runfang Zhou
package XB_LDAP;
require Exporter;
@ISA = qw(Exporter);
@Export = qw();
@EXPORT_OK = qw( LDAP_search LDAP_register LDAP_unregister );
use strict;
use sigtrap;
use Data::Dumper;
use XB_Log;
use Net::LDAPS;
use XB_Params;
my $modname = "XB_LDAP::";
# Description:
# Connect to the LDAP server
# Arguments:
# Already specified in the node_opts. Should we support
# overriding of those values?
# Returns:
# $ldap - handle to the connection
# Exceptions:
# XB_LDAP::connect
#
sub LDAP_connect () {
my ($ldap);
my $procname = "LDAP_connect";
#XB_Log::log "info", "-> $modname$procname";
eval {
# Options that must be used
my $ldapconf = $XB_Params::node_opts{'ldap'};
(not defined $ldapconf) and
XB_Log::log ("debug3", "node_opts{ldap} undefined here") and
die "ldap";
#XB_Log::log "debug1",
# "LDAP server configuration used = " . Dumper($ldapconf);
$ldap =
Net::LDAPS -> new
($ldapconf->{server},
version => $ldapconf->{version},
port => $ldapconf->{port},
cafile => $ldapconf->{ca_cert},
clientcert => $ldapconf->{node_cert},
clientkey => $ldapconf->{node_key},
verify => 'require',
debug => 0,
) or do {
XB_Log::log ("debug3", "Unable to connect to server $@");
die "connect";
};
};
#XB_Log::log "info", "<- $modname$procname";
return ($ldap) unless $@;
unless ($@ =~ /^(connect|ldap)/){
XB_Log::log "warning", " ! $procname caught unexpected exception $@";
}
die "$modname$procname";
};
# Description:
# binds to the object corresponding this host
# Arguments:
# handle returned by connect
# Returns:
# nothing
# Exceptions:
# XB_LDAP::LDAP_bind
#
sub LDAP_bind ($) {
#XXX has to use profiles
my ($ldap) = @_;
my $procname = "LDAP_bind";
#XB_Log::log "info", "-> $modname$procname";
eval {
# Options that must be used
my $ldapconf = $XB_Params::node_opts{'ldap'};
#=> this is the DN to which we will bind
my $dn = $ldapconf->{userdn};
my $mesg = $ldap->bind($dn,
password => $ldapconf->{password},
version => $ldapconf->{version}) ;
if ($mesg->code) {
XB_Log::log ("debug3", "Unable to the bind to dn $dn" . $mesg->error);
die "bind";
}
};
#XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
unless ($@ =~ /^(bind)/){
XB_Log::log "warning", " ! $procname caught unexpected exception $@";
}
die "$modname$procname";
}
# Description:
# unbinds
# Arguments:
# handle returned by connect
# Returns:
# nothing
# Exceptions:
# XB_LDAP::unbind
#
sub LDAP_unbind ($) {
my ($ldap) = @_;
my $procname = "LDAP_unbind";
#XB_Log::log "info", "-> $modname$procname";
eval {
$ldap->unbind() or do {
XB_Log::log ("debug3", "Unable to the unbind") and
die "unbind";
}
};
#XB_Log::log "info", "<- $modname$procname";
return ($ldap) unless $@;
unless ($@ =~ /^(unbind)/){
XB_Log::log "warning", " ! $procname caught unexpected exception $@";
}
die "$modname$procname";
}
# Description:
# search for specific attributes under a given prefix tree
# Arguments:
# what? -
#
# Returns:
#
# Exceptions:
#
sub LDAP_search ($$;$) {
my ($what,$where,$attrvals) = @_;
my ($dn, @attrlist, %results) = ();
my $procname = "LDAP_search";
#XB_Log::log "info", "-> $modname$procname";
eval {
#=> connect to the server;
my $ldap = LDAP_connect();
LDAP_bind($ldap);
my $ldapconf = $XB_Params::node_opts{'ldap'};
my $hostname = $ldapconf->{hostname};
my $instance = $ldapconf->{instance};
if ($what !~ /(config|registry|acl|ca)/) {
XB_Log::log ("debug3", "Search target ($what) is inappropriate");
die "params";
}
if ($where !~ /(local|global)/) {
XB_Log::log ("debug3", "Search scope ($where) is inappropriate");
die "params";
}
$_ = $what;
SWITCH : {
(/config/i) and do {
$dn = "cn=$instance,cn=$hostname,ou=config,ou=$where,ou=xbone";
@attrlist = ( "xbattr", "xbacl", "xbregister");
#=> do the actual search
my $mesg =
$ldap->search( # perform a search
base => $dn,
filter => "(objectClass=XBoneInstance)"
);
$mesg->code and do {
XB_Log::log ("debug3", $mesg->error);
die "search";
};
#=> process the reply
foreach my $entry ($mesg->entries)
{
#$entry->dump;
foreach my $attr (@attrlist){
# XXX have to handle multivalued attributes here
my @list = $entry->get_value($attr);
$results{$hostname}{$attr} = \@list;
}; # for each attribute
};
last SWITCH;
};
(/registry/i) and do {
my %subdirs = ();
$subdirs{local}{privateregistry} = 1;
$subdirs{local}{registry} = 1;
if ($where !~ /^(global)$/) {
$subdirs{global}{registry} = 1;
}
foreach my $scope (keys %subdirs){
foreach my $dir (keys %{$subdirs{$scope}}){
$dn = "ou=$dir,ou=$scope,ou=xbone";
@attrlist = ( "xbattr" );
my $filter = "(objectClass=XBoneInstance)";
if (defined $attrvals){
foreach my $attr (keys %{$attrvals}){
my $val = $attrvals->{$attr};
my $exp = "(xbattr=\'$attr = $val\')";
$filter = $filter . $exp;
}
}
$filter = "(\&$filter)";
#=> do the actual search
my $mesg =
$ldap->search( # perform a search
base => $dn,
filter => $filter,
);
$mesg->code and do {
XB_Log::log ("debug3", $mesg->error);
die "search";
};
#=> process the reply
foreach my $entry ($mesg->entries)
{
#$entry->dump;
$hostname = $entry->get_value("cn");
next if (not defined $hostname or $hostname eq "");
foreach my $attr (@attrlist){
# XXX have to handle multivalued attributes here
my @list = $entry->get_value($attr);
$results{$hostname}{$attr} = \@list;
}; # for each attribute
};
}; #subdirectories
}; # scope
last SWITCH;
};
(/acl/i) and do {
my %subdirs = ();
$subdirs{local}{acl} = 1;
if ($where !~ /^(global)$/) {
$subdirs{global}{acl} = 1;
}
foreach my $scope (keys %subdirs){
$dn = "ou=acl,ou=$scope,ou=xbone";
@attrlist = ( "xbacl" );
#=> do the actual search
my $mesg =
$ldap->search( # perform a search
base => $dn,
filter => "(objectClass=XBoneGroup)"
);
$mesg->code and do {
XB_Log::log ("debug3", $mesg->error);
die "search";
};
#=> process the reply
foreach my $entry ($mesg->entries)
{
#$entry->dump;
$hostname = $entry->get_value("cn");
next if (not defined $hostname or $hostname eq "");
foreach my $attr (@attrlist){
# XXX have to handle multivalued attributes here
my @list = $entry->get_value($attr);
$results{$hostname}{$attr} = \@list;
}; # for each attribute
};
}; # scope
last SWITCH;
};
(/^(ca)$/i) and do {
my %subdirs = ();
$subdirs{local}{ca} = 1;
if ($where !~ /^(global)$/) {
$subdirs{global}{ca} = 1;
}
foreach my $scope (keys %subdirs){
foreach my $dir (keys %{$subdirs{$scope}}){
$dn = "ou=$dir,ou=$scope,ou=xbone";
@attrlist = ( "cACertificate;binary",
"certificateRevocationList;binary" );
#=> do the actual search
my $mesg =
$ldap->search( # perform a search
base => $dn,
filter => "(objectClass=XBoneCA)"
);
$mesg->code and do {
XB_Log::log ("debug3", $mesg->error);
die "search";
};
#=> process the reply
foreach my $entry ($mesg->entries)
{
#$entry->dump;
$hostname = $entry->get_value("cn");
next if (not defined $hostname or $hostname eq "");
foreach my $attr (@attrlist){
# XXX have to handle multivalued attributes
my @list = $entry->get_value($attr);
$results{$hostname}{$attr} = \@list;
}; # for each attribute
};
};
};
last SWITCH;
};
};
#XB_Log::log "info", "LDAP results" . Dumper(\%results);
LDAP_unbind($ldap);
};
#XB_Log::log "info", "<- $modname$procname";
return (\%results) unless $@;
unless ($@ =~ /^(params|unbind|bind|connect|search)/){
XB_Log::log "warning", " ! $procname caught unexpected exception $@";
}
die "$modname$procname";
};
# Description:
# registers attributes for a given host
# Arguments:
# attribute hash (
# <attribute> => <value> (MAY)
# :
# <attribute> => <value> (MAY)
# )
# Returns:
#
# Exceptions:
#
sub LDAP_register ($) {
my ($attrhash) = @_;
my ($ldap, $result, $dn, @reghash);
my $procname = "LDAP_register";
#XB_Log::log "info", "-> $modname$procname";
eval {
#=> connect to the server;
$ldap = LDAP_connect;
LDAP_bind($ldap);
my $ldapconf = $XB_Params::node_opts{'ldap'};
my $hostname = $ldapconf->{hostname};
my $server = $ldapconf->{server};
my $scope = $ldapconf->{scope};
my $dir = "registry";
if ( $ldapconf->{scope} !~ /(global)/i){
$dir = "privateregistry";
}
eval {
# create a group entry if that doesnt already exist.
$dn = "cn=$server,ou=$dir,ou=local,ou=xbone";
my $mesg =
$ldap->search( # perform a search
base => $dn,
filter => "(objectClass=XBoneGroup)"
);
if ( $mesg->code ) {
$@ = "";
@reghash = [
'objectclass' => 'XBoneGroup',
'cn' => $server,
];
$result =
$ldap->add($dn, 'attr' => @reghash);
$result->code and
XB_Log::log ("debug3", $result->error) and
die("search");
} else {
#XB_Log::log ("debug3", "Group node already exists. ".
# "So dont bother");
}
};
if ($@) {
XB_Log::log ("err", "Either the oid $dn does not " .
"exist or cannot be created. $@ ");
die("search");
};
# Now create the host-specific entry.
$dn = "cn=$hostname,cn=$server,ou=$dir,ou=local,ou=xbone";
# copy the necessary attributes
my @xbattr = ();
foreach my $attr (keys %{$attrhash}){
next if ($attr eq "enable");
next if ($attr eq "variable");
my $val = $attrhash->{$attr};
my $entry = "\'$attr = $val\'";
push (@xbattr, $entry);
};
@reghash = [
'objectclass' => 'XBoneInstance',
'cn' => $hostname,
'xbattr' => \@xbattr
];
# delete the old entry and ignore the result
$result = $ldap->delete($dn);
# now create the new entry
$result =
$ldap->add($dn, 'attr' => @reghash);
$result->code and
XB_Log::log ("debug3", $result->error) and
die "add";
LDAP_unbind($ldap);
};
#XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
unless ($@ =~ /^(unbind|bind|connect|add)/){
XB_Log::log "warning", " ! $procname caught unexpected exception $@";
}
die "$modname$procname";
};
# Description:
# delete an entry
# Arguments:
# XXX ? what should be passed to this function?
# Returns:
#
# Exceptions:
#
sub LDAP_unregister () {
my $ldap;
my $procname = "LDAP_unregister";
#XB_Log::log "info", "-> $modname$procname";
my $result;
eval {
#=> connect to the server;
$ldap = LDAP_connect;
LDAP_bind($ldap);
my $ldapconf = $XB_Params::node_opts{'ldap'};
my $hostname = $ldapconf->{hostname};
my $server = $ldapconf->{server};
my $dir = "registry";
if ( $ldapconf->{scope} !~ /(global)/i){
$dir = "privateregistry";
}
my $dn = "cn=$hostname,cn=$server,ou=$dir,ou=local,ou=xbone";
$result = $ldap->delete($dn);
$result->code and
XB_Log::log ("debug3", $result->error) and
die "delete";
LDAP_unbind($ldap);
};
#XB_Log::log "info", "<- $modname$procname";
return ($result) unless $@;
unless ($@ =~ /^(unbind|bind|connect|delete)/){
XB_Log::log "warning", " ! $procname caught unexpected exception $@";
}
die "$modname$procname";
};
1;
__END__
syntax highlighted by Code2HTML, v. 0.9.1