### 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__