Torus/Driver/ldap.pm

package Torus::Driver::ldap;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw( );

use strict;
use warnings;

# load configuration-data from ini-file
BEGIN {
  use loadConfig;
}

use Net::LDAP;
use Net::LDAP::Entry;
#use Unicode::MapUTF8 qw(to_utf8 from_utf8 utf8_supported_charset);
use Data::Transform::Encode qw( var2utf8 var_utf2iso );
use Data::Storage::Handler::File qw( a2f );
use Data::Dumper;

my $hr = "=" x 80 . "\n";

# debugging?
my $DEBUGLEVEL = $config->get("debug_level");
my $TRACELEVEL = $config->get("trace_level");

my $dnCache;
my $criticalCache;
my $msgCache;


# ==================================================
#    configure here
# ==================================================
#my $binddn = 'cn=root, dc=labnet, dc=de';
my $binddn = 'cn=admin, o=netfrag.org, c=de';
#my $binddn = 'cn=admin';

# V1: hardcoded target ou
#my $basedn = 'ou=Adressen, dc=labnet, dc=de';

# V2: now passed-in to "addEntry"

my $cfg_objectclasses = [ qw( 
                Person
                inetOrgPerson 
                organizationalPerson
                pilotPerson
                groupOfNames
                ) ];
#               msMapi
#               outlookPerson

#
# other object classes:
# outlookPerson
# ==================================================


my $ldap;
my $map;

my $ldap_errors_file = '../log/ldap_errors.log';
sub ldapError {
  my $message = shift;
#print Dumper($message);
  my $textMessage = $message->error . " - code: " . $message->code;
  $textMessage .= " - dn: " . $message->{matchedDN} if $message->{matchedDN};
  #print "msg: '$textMessage'", "\n";
  a2f($ldap_errors_file, $textMessage) if !$TRACELEVEL;
  return $message;
}

sub connectStore {

  #print Dumper($config->get("ldapserver_host"));

  #$ldap = Net::LDAP->new('localhost', onerror => 'warn');
  $ldap = Net::LDAP->new(
    $config->get("ldapserver_host"),
    #port => 389,
    #timeout => 120,
    debug => 0,
    #async => 1,
    #onerror => 'warn',
    onerror => \&ldapError,
    #version => 3,
  ) 
  or die("could not connect to ldap-server!");
  
  $ldap->bind ( 
    $binddn,
    password => 'secret'
  ) or die "$@";

}

sub disconnectStore {
  $ldap->unbind;   # take down session
}

sub getEntry {

  die("getEntry!");
  
  my $basedn = '';
  
  connectStore();

        my $mesg = $ldap->search (  # perform a search
                               base   => $basedn,
                               filter => "(&(sn=*))"
                              );

        $mesg->code && die $mesg->error;

  foreach my $entry ($mesg->all_entries) { 
    $entry->dump;
    print "\n";
  }

  disconnectStore();

}

sub _example {
   print "abcdef", "\n";
        my $result = $ldap->add ( 
                     'cn = Barbara Jensen, o=University of Michigan, c=us',
                      attr => [ 'cn'   => [ 'Barbara Jensen', 'Barbs Jensen' ],
                                'sn'   => 'Jensen',
                                'mail' => 'b.jensen@umich.edu',
                                'objectclass' => ['top', 'person',
                                                  'organizationalPerson',
                                                  'inetOrgPerson' ],
                              ]
                    );

}

sub changeEntry {

  my $dn = shift;
  my $

            $ldap->modify( $dn,
              changes => [
                add     => [ sn => 'Barr' ],              # Add sn=Barr
                delete  => [ faxNumber => []],            # Delete all fax numbers
                delete  => [ telephoneNumber => ['911']], # delete phone number 911
                replace => [ email => 'gbarr@pobox.com']  # change email address
              ]
            );

}


sub prepareEntry {

  my $basedn = shift;
  my $mapiEntry = shift;
  
  my $ldapEntry;

  my $mapfile = '../etc/' . $config->get("fields_mapfile");
  readFieldMapping($mapfile);

  # dump mapi-entry - don't do that! this is large!
  #print Dumper($mapiEntry);
  #exit;

  # utf8-conversion of unmapped mapi-entry - don't do that! this is large!
  #var2utf8($mapiEntry);

  # map entry
  foreach my $mapiKey (keys %{$mapiEntry}) {
    my $ldapKey = $map->{ldap}{$mapiKey};
    my $ldapValue = $mapiEntry->{$mapiKey};
    next if (!$ldapKey);

    # utf8-conversion
    #$ldapKey   = toUTF8($ldapKey);
    #$ldapValue = toUTF8($ldapValue);

    $ldapEntry->{$ldapKey} = $ldapValue;
  }
  
  # utf8-conversion of mapped ldap-entry
  var2utf8($ldapEntry);

  # dump ldap-entry - this is okay
  #print "ldap-entry before adding:", "\n";
  #print STDOUT Dumper($ldapEntry);
    
  # build dn here
  my $entryIdentifier = buildSnCn( {
    #sn => $sn,
    #givenname => $ldapEntry->{givenname},
    LastName => $mapiEntry->{LastName},
    FirstName => $mapiEntry->{FirstName},
    FileAs => $mapiEntry->{FileAs},
    CompanyName => $mapiEntry->{CompanyName},
    EntryID => $mapiEntry->{EntryID},
  } );
  
  my $sn = $entryIdentifier->{sn};
  my $cn = $entryIdentifier->{cn};
  
  if (!$cn) {
    rememberCriticalEntry("mapi", $mapiEntry->{EntryID});
    logError('App', "Couldn't build required ldap-attribute \"cn\". LastName/FirstName/FileAs/CompanyName were empty.");
    return;
  }
  
  # remember all already used "cn"s
  addDnCache($cn);
  
  my $must = {
    cn => $cn,
    sn => $sn,
    member => $ldapEntry->{member},
    objectClass => $cfg_objectclasses,
  };
  # utf8-conversion of must-have fields
  var2utf8($must);

  my $dn = buildDn( { basedn => $basedn, cn => $must->{cn} } );
  rememberMessage($dn, $entryIdentifier->{info});

  return { identifier => $dn, must => $must, may => $ldapEntry };
  
}

sub addEntry {
    
  my $entry_raw = shift;
  
  #print Dumper($entry_raw);
  #return;
  
  my $identifier = $entry_raw->{identifier};
  my $must = $entry_raw->{must};
  my $may = $entry_raw->{may};
  
  my $dn = $identifier;
    
  # delete entry (dn) first
  if (existsEntry('cn', $dn)) {
    print "entry exists (dn='$dn') deleting", "\n" if $DEBUGLEVEL > 3;
    $ldap->delete($dn);
  }

  #print "dn: $dn", "\n";
  #exit;

  my $entry = Net::LDAP::Entry->new;
  $entry->dn($dn);
  
  $entry->add(
    cn => $must->{cn},
    sn => $must->{sn},
    member => $must->{dn},
    objectClass => $must->{objectClass},
   );
    #sn => 'Nachname',
    #cn => 'Vorname Nachname',
   my $result1 = $entry->add(%{$may});

#print Dumper($result1), "\n";
#print Dumper($entry);

  my $result = $entry->update($ldap);
  #print Dumper($ldap->sync());

#print "result:", "\n";
#print Dumper($result);
#exit;

  #print "trace-level > 0: ", ($config->get("trace_level") > 0), "\n";
  #exit;
  
  #traceEntry($mapiEntry, $entry, { error => $error, prefix => $result->error }) if $TRACELEVEL >= 2;
  #return 1 if !$error;

  return $result;

}

sub logError {
  my $type = shift;
  my $message = shift;
  my $options = shift;
  if ($DEBUGLEVEL >= 1) {
    print STDOUT "\n" if $DEBUGLEVEL <= 1;
    print STDOUT "ERROR ($type): $message", "\n" ;
    my $buffer = '';
    foreach (keys %$options) {
      $buffer .= "  $_: $options->{$_}\n" if $options->{$_};
    }
    #print STDOUT Dumper($options), "\n";
    print STDOUT $buffer;
  }
}

sub logInfo {
  my $type = shift;
  my $message = shift;
  if ($DEBUGLEVEL >= 1) {
    print STDOUT "\n" if $DEBUGLEVEL <= 1;
    print STDOUT "INFO ($type): $message", "\n" ;
  }
}

sub traceEntry {
  my $entry_source = shift;
  my $entry_target = shift;
  my $options = shift;
  
  my $logfile = '../log/transfer.log';
  if ($options->{error}) {
    $logfile = '../log/errors.log';
  }
  
  my $dump_source = Dumper($entry_source);
  
  #my $dump_target = Dumper($entry_target);
  my $dump_target = "\n";
  foreach my $attr ($entry_target->attributes) {
    my $subentry = $attr . ": ";
    my @value = $entry_target->get_value($attr);
    if ($#value > 0) {
      #push @value, "\n   ";
      $subentry .= "\n   ";
    }
    $subentry .= join("\n   ", @value);
    $dump_target .= $subentry . "\n";
  }
  
  my $dump = <<EOD;
  $hr
  MAPI-Object:
  $dump_source
  $hr
  Net::LDAP::Entry:
  $dump_target
  $hr
EOD

  $dump = $hr . $options->{prefix} . $dump if $options->{prefix};

  a2f($logfile, $dump);
  
}

sub toUTF8 {
  my $string = shift;
  #return to_utf8( -string => $string, -charset => 'ISO-8859-1');
  print "before: $string", "\n";
  var2utf8(\$string);
  print "after: $string", "\n";
  return $string;
}

sub readFieldMapping {
  my $mapfile = shift;
  if (! -e $mapfile) {
    print "mapfile \"$mapfile\" does not exist.", "\n";
    exit;
  }
  open(FH, '<', $mapfile);
    while(<FH>) {
      s/\r\n/\n/g;
      chomp();
      next if (m/^#/);
      my @entry = split(';', $_);
      my $key = $entry[0];
      my $key_ldap = $entry[1];
      $key_ldap ||= '';
      $map->{mapi}{$key} = 1;
      $map->{ldap}{$key} = $key_ldap;
    }
  close(FH);
}

sub createOuSafe {
  
  #my $basedn = shift;
  #my $cn = shift;

  #my $dn = 'cn=' . $cn . ', ' . $basedn;
  my $dn = shift;

  #print "orig-dn: $dn", "\n";
  
  $dn =~ m/ou=([\w|\.]+?)[,|].*/;
  my $ou = $1;
  #print "ou: '$ou'", "\n";
  
  my $basedn = $dn;
  $basedn =~ s/ou=$ou, //;
  #print "basedn: $basedn", "\n";
  #exit;
  
  print "checking ou: (basedn='$basedn', ou='$ou')", "\n" if $DEBUGLEVEL > 3;
#  if (checkOu($basedn, $ou)) {
  if (existsEntry('ou', $dn)) {
    return $dn;
  }
  
  if (my @ou_address = split(/\./, $ou)) {
    return createDeepOu($basedn, \@ou_address);
  } else {
    return createOu($dn, $ou);
  }
  
}

sub createDeepOu {
  my $basedn = shift;
  my $ou_address = shift;
  my $dn = $basedn;
  print "creating deep ou (basedn='$basedn')", "\n" if $DEBUGLEVEL > 3;
  foreach (@$ou_address) {
    my $ou = $_;
    #print "ou: $ou", "\n";
    $dn = "ou=$ou, " . $dn;
    #print "dn: $dn", "\n";
    createOu($dn, $ou);
  }
  return $dn;
}

sub createOu {
  my $dn = shift;
  my $ou = shift;
  print "creating ou (DN='$dn', OU='$ou')", "\n" if $DEBUGLEVEL > 3;
  my $entry = Net::LDAP::Entry->new;
  $entry->dn($dn);
  $entry->add(
    #cn => $cn,
    ou => $ou,
    objectClass => 'organizationalUnit',
  );
  my $result = $entry->update($ldap);
  #return $result;
  return $dn;
}

sub checkOu {
  my $basedn = shift;
  my $ou = shift;

  my $mesg = $ldap->search (                # perform a search
                         base   => $basedn,
                         filter => "(&(ou=$ou))"
                        );
  
  #print "search-result-code: ", $mesg->code, "\n";
  #print "search-result-error: ", $mesg->error, "\n";
  
  #return;
  #print Dumper($mesg);
  #exit;
  
  #$mesg->code && die $mesg->error;

  return 1 if exists $mesg->{entries};

}

sub existsEntry {
  
  my $ldapType = shift;
  my $dn = shift;
  
  my $filter = "$ldapType =*";
  #print "using filter: '$filter'", "\n";

  # get part from full LDAP-address
  #print "dn: $dn", "\n";
  #$dn =~ m/$ldapType=([\w|\.| ]+?)[,|].*/;
  #my $part = $1;

  # cut part
  #print "ldapType: $ldapType", "\n";
  #print "part: $part", "\n";
  #$dn =~ s/$ldapType=$part, //;

  # TODO:
  # - split 'ou' or 'cn' from 'dn' here to create a search-attribute (one) and a $basedn (a parent node)
  # - run search with $filter = 'ou|cn =*' (<part-from-regex>) and $basedn=(<rest-from-regex>)
  
  $filter = "(objectClass=*)";
  #print "searching for dn='$dn' with filter='$filter'", "\n";
  my $mesg = $ldap->search (                # perform a search
                         base   => $dn,
                         filter => $filter,
#                         filter => "(&(ou=*))"
                        );
  
  #print "search-result-code: ", $mesg->code, "\n";
  #print "search-result-error: ", $mesg->error, "\n";
  
  #return;
  #print Dumper($mesg);
  #exit;
  
  #$mesg->code && die $mesg->error;

  return 1 if exists $mesg->{entries};
  return 0;

}

sub buildSnCn {
  my $parts = shift;
  
  my $logmsg;
  
  my $cn;
  
  if ($parts->{LastName}) {
    # use pure "sn" first!
    $cn = $parts->{LastName} ;
  
    # add "givenname" to "cn" if exists
    $cn = $parts->{FirstName} . ' ' . $cn if $parts->{FirstName};
  }

  # check if "cn" is already filled, else provide some fallback-mechanism(s) here
    # use "FileAs"
    if (!$cn && $parts->{FileAs}) {
      $cn = $parts->{FileAs};
      $logmsg = "using \"FileAs\" for \"cn\": $cn";
    }
    # use "FirstName"
    if (!$cn && $parts->{FirstName}) {
      $cn = $parts->{FirstName};
      $logmsg = "using \"FirstName\" for \"cn\": $cn";
    }
    # use "CompanyName"
    if (!$cn && $parts->{CompanyName}) {
      $cn = $parts->{CompanyName};
      $logmsg = "using \"CompanyName\" for \"cn\": $cn";
    }

  # handle "must-have"-field "sn"
    my $sn = $parts->{LastName};

  # additional (last) rule: use unique identifier (EntryID) as "cn" if it's still empty
    #$cn = 'ident - ' . $parts->{EntryID} if !$cn;
    if (!$cn) {
      $cn = $parts->{EntryID};
      $logmsg = "\"cn\" was empty, using EntryID.\n  - cn: $cn";
    }

  # fallback to "cn" if "sn" is empty
    $sn = $cn if !$sn;
  
  # check for collisions in "cn"s
    if (dnAlreadyUsed($cn)) {
      #logError('App', "Couldn't use cn='$cn' - already exists!");
      #return;
      $cn .= '-' . $parts->{EntryID};
      $logmsg .= "\n  - modified \"cn\" to prevent name-collision.\n  - cn: $cn";
    }

    #$msgCache->{} = $logmsg;
    logInfo('App::buildCn', $logmsg) if $logmsg;

    return { sn => $sn, cn => $cn, info => $logmsg };
  
}

sub buildDn {
  my $parts = shift;
  
  # build "dn"
  my $dn = join(', ', "cn=" . $parts->{cn}, $parts->{basedn});
  
  # patch dn (remove forbidden characters)
  $dn =~ s/\+/&/g;
  
  return $dn;
}

sub clearDnCache {
  $dnCache = {};
  $msgCache = {};
}

sub addDnCache {
  my $key = shift;
  $dnCache->{$key}++;
}

sub dnAlreadyUsed {
  my $key = shift;
  return exists $dnCache->{$key};
}

sub rememberCriticalEntry {
  my $type = shift;
  my $identifier = shift;
  push @$criticalCache, { type => $type, identifier => $identifier };
}

sub showCriticalEntries {
  return if !$criticalCache;
  my @criticals = @$criticalCache;
  if ($#criticals != -1) {
    print "=" x 60, "\n";
    print "Some errors occoured while processing data, show details? (y|n) ";
    my $answer = <STDIN>;
    print "\n";
    if ($answer =~ m/^y/i) {
      foreach (@criticals) {
        #print join("\n", @criticals);
        #print Dumper($_);
        print $_->{type}, ": ", $_->{identifier}, "\n";
        print "  ", $msgCache->{$_->{identifier}}, "\n";
        delete $msgCache->{$_->{identifier}};
      }
    }
  }
}

sub showGoodEntries {
  print "=" x 60, "\n";
  print "Show good entries? (y|n) ";
  my $answer = <STDIN>;
  print "\n";
  if ($answer =~ m/^y/i) {
    foreach (keys %$msgCache) {
      print $_, ": ", $msgCache->{$_}, "\n" if $msgCache->{$_};
    }
  }
}

sub processResult {

  my $dn = shift;
  my $result = shift;

#print "dn: $dn", "\n";
#print Dumper($result);

  my $error = 0;
  my $error_code;
  my $error_message;
  if ($result) {
    $error_code = $result->code;
    $error_message = $result->error;
  } else {
    $error_code = 'n/a';
    $error_message = "NO RESULT FROM LDAP-SERVER";
  }
  
  if ($error_code) {
    rememberCriticalEntry("ldap", $dn);
    my $errmesg = "(error=$error_message, code=$error_code)";
    rememberMessage($dn, $errmesg);
    logError("LDAP", $errmesg, { dn => $dn } );
    $error = 1;
  } else {
    print "SUCCESS for (dn='$dn')", "\n" if $DEBUGLEVEL > 1;
  }
  
  undef $result;
}

sub rememberMessage {
  my $ident = shift;
  my $mesg = shift;
  $msgCache->{$ident} = $mesg;
}

1;
1	joko	1.1	package Torus::Driver::ldap;
2
3			require Exporter;
4			our @ISA = qw(Exporter);
5			our @EXPORT = qw( );
6
7			use strict;
8			use warnings;
9
10			# load configuration-data from ini-file
11			BEGIN {
12			use loadConfig;
13			}
14
15			use Net::LDAP;
16			use Net::LDAP::Entry;
17			#use Unicode::MapUTF8 qw(to_utf8 from_utf8 utf8_supported_charset);
18			use Data::Transform::Encode qw( var2utf8 var_utf2iso );
19			use Data::Storage::Handler::File qw( a2f );
20			use Data::Dumper;
21
22			my $hr = "=" x 80 . "\n";
23
24			# debugging?
25			my $DEBUGLEVEL = $config->get("debug_level");
26			my $TRACELEVEL = $config->get("trace_level");
27
28			my $dnCache;
29			my $criticalCache;
30			my $msgCache;
31
32
33			# ==================================================
34			# configure here
35			# ==================================================
36	joko	1.2	#my $binddn = 'cn=root, dc=labnet, dc=de';
37			my $binddn = 'cn=admin, o=netfrag.org, c=de';
38			#my $binddn = 'cn=admin';
39	joko	1.1
40			# V1: hardcoded target ou
41			#my $basedn = 'ou=Adressen, dc=labnet, dc=de';
42
43			# V2: now passed-in to "addEntry"
44
45			my $cfg_objectclasses = [ qw(
46			Person
47			inetOrgPerson
48			organizationalPerson
49			pilotPerson
50			groupOfNames
51			) ];
52	joko	1.2	# msMapi
53	joko	1.1	# outlookPerson
54
55			#
56			# other object classes:
57			# outlookPerson
58			# ==================================================
59
60
61			my $ldap;
62			my $map;
63
64			my $ldap_errors_file = '../log/ldap_errors.log';
65			sub ldapError {
66			my $message = shift;
67			#print Dumper($message);
68			my $textMessage = $message->error . " - code: " . $message->code;
69			$textMessage .= " - dn: " . $message->{matchedDN} if $message->{matchedDN};
70			#print "msg: '$textMessage'", "\n";
71			a2f($ldap_errors_file, $textMessage) if !$TRACELEVEL;
72			return $message;
73			}
74
75			sub connectStore {
76
77			#print Dumper($config->get("ldapserver_host"));
78
79			#$ldap = Net::LDAP->new('localhost', onerror => 'warn');
80			$ldap = Net::LDAP->new(
81			$config->get("ldapserver_host"),
82			#port => 389,
83			#timeout => 120,
84			debug => 0,
85			#async => 1,
86			#onerror => 'warn',
87			onerror => \&ldapError,
88			#version => 3,
89			)
90			or die("could not connect to ldap-server!");
91
92			$ldap->bind (
93			$binddn,
94	joko	1.2	password => 'secret'
95	joko	1.1	) or die "$@";
96
97			}
98
99			sub disconnectStore {
100			$ldap->unbind; # take down session
101			}
102
103			sub getEntry {
104
105			die("getEntry!");
106
107			my $basedn = '';
108
109			connectStore();
110
111			my $mesg = $ldap->search ( # perform a search
112			base => $basedn,
113			filter => "(&(sn=*))"
114			);
115
116			$mesg->code && die $mesg->error;
117
118			foreach my $entry ($mesg->all_entries) {
119			$entry->dump;
120			print "\n";
121			}
122
123			disconnectStore();
124
125			}
126
127			sub _example {
128			print "abcdef", "\n";
129			my $result = $ldap->add (
130			'cn = Barbara Jensen, o=University of Michigan, c=us',
131			attr => [ 'cn' => [ 'Barbara Jensen', 'Barbs Jensen' ],
132			'sn' => 'Jensen',
133			'mail' => 'b.jensen@umich.edu',
134			'objectclass' => ['top', 'person',
135			'organizationalPerson',
136			'inetOrgPerson' ],
137			]
138			);
139
140			}
141
142			sub changeEntry {
143
144			my $dn = shift;
145			my $
146
147			$ldap->modify( $dn,
148			changes => [
149			add => [ sn => 'Barr' ], # Add sn=Barr
150			delete => [ faxNumber => []], # Delete all fax numbers
151			delete => [ telephoneNumber => ['911']], # delete phone number 911
152			replace => [ email => 'gbarr@pobox.com'] # change email address
153			]
154			);
155
156			}
157
158
159			sub prepareEntry {
160
161			my $basedn = shift;
162			my $mapiEntry = shift;
163
164			my $ldapEntry;
165
166			my $mapfile = '../etc/' . $config->get("fields_mapfile");
167			readFieldMapping($mapfile);
168
169			# dump mapi-entry - don't do that! this is large!
170			#print Dumper($mapiEntry);
171			#exit;
172
173			# utf8-conversion of unmapped mapi-entry - don't do that! this is large!
174			#var2utf8($mapiEntry);
175
176			# map entry
177			foreach my $mapiKey (keys %{$mapiEntry}) {
178			my $ldapKey = $map->{ldap}{$mapiKey};
179			my $ldapValue = $mapiEntry->{$mapiKey};
180			next if (!$ldapKey);
181
182			# utf8-conversion
183			#$ldapKey = toUTF8($ldapKey);
184			#$ldapValue = toUTF8($ldapValue);
185
186			$ldapEntry->{$ldapKey} = $ldapValue;
187			}
188
189			# utf8-conversion of mapped ldap-entry
190			var2utf8($ldapEntry);
191
192			# dump ldap-entry - this is okay
193			#print "ldap-entry before adding:", "\n";
194			#print STDOUT Dumper($ldapEntry);
195
196			# build dn here
197			my $entryIdentifier = buildSnCn( {
198			#sn => $sn,
199			#givenname => $ldapEntry->{givenname},
200			LastName => $mapiEntry->{LastName},
201			FirstName => $mapiEntry->{FirstName},
202			FileAs => $mapiEntry->{FileAs},
203			CompanyName => $mapiEntry->{CompanyName},
204			EntryID => $mapiEntry->{EntryID},
205			} );
206
207			my $sn = $entryIdentifier->{sn};
208			my $cn = $entryIdentifier->{cn};
209
210			if (!$cn) {
211			rememberCriticalEntry("mapi", $mapiEntry->{EntryID});
212			logError('App', "Couldn't build required ldap-attribute \"cn\". LastName/FirstName/FileAs/CompanyName were empty.");
213			return;
214			}
215
216			# remember all already used "cn"s
217			addDnCache($cn);
218
219			my $must = {
220			cn => $cn,
221			sn => $sn,
222			member => $ldapEntry->{member},
223			objectClass => $cfg_objectclasses,
224			};
225			# utf8-conversion of must-have fields
226			var2utf8($must);
227
228			my $dn = buildDn( { basedn => $basedn, cn => $must->{cn} } );
229			rememberMessage($dn, $entryIdentifier->{info});
230
231			return { identifier => $dn, must => $must, may => $ldapEntry };
232
233			}
234
235			sub addEntry {
236
237			my $entry_raw = shift;
238
239			#print Dumper($entry_raw);
240			#return;
241
242			my $identifier = $entry_raw->{identifier};
243			my $must = $entry_raw->{must};
244			my $may = $entry_raw->{may};
245
246			my $dn = $identifier;
247
248			# delete entry (dn) first
249			if (existsEntry('cn', $dn)) {
250			print "entry exists (dn='$dn') deleting", "\n" if $DEBUGLEVEL > 3;
251			$ldap->delete($dn);
252			}
253
254			#print "dn: $dn", "\n";
255			#exit;
256
257			my $entry = Net::LDAP::Entry->new;
258			$entry->dn($dn);
259
260			$entry->add(
261			cn => $must->{cn},
262			sn => $must->{sn},
263			member => $must->{dn},
264			objectClass => $must->{objectClass},
265			);
266			#sn => 'Nachname',
267			#cn => 'Vorname Nachname',
268			my $result1 = $entry->add(%{$may});
269
270			#print Dumper($result1), "\n";
271			#print Dumper($entry);
272
273			my $result = $entry->update($ldap);
274			#print Dumper($ldap->sync());
275
276			#print "result:", "\n";
277			#print Dumper($result);
278			#exit;
279
280			#print "trace-level > 0: ", ($config->get("trace_level") > 0), "\n";
281			#exit;
282
283			#traceEntry($mapiEntry, $entry, { error => $error, prefix => $result->error }) if $TRACELEVEL >= 2;
284			#return 1 if !$error;
285
286			return $result;
287
288			}
289
290			sub logError {
291			my $type = shift;
292			my $message = shift;
293			my $options = shift;
294			if ($DEBUGLEVEL >= 1) {
295			print STDOUT "\n" if $DEBUGLEVEL <= 1;
296			print STDOUT "ERROR ($type): $message", "\n" ;
297			my $buffer = '';
298			foreach (keys %$options) {
299			$buffer .= " $_: $options->{$_}\n" if $options->{$_};
300			}
301			#print STDOUT Dumper($options), "\n";
302			print STDOUT $buffer;
303			}
304			}
305
306			sub logInfo {
307			my $type = shift;
308			my $message = shift;
309			if ($DEBUGLEVEL >= 1) {
310			print STDOUT "\n" if $DEBUGLEVEL <= 1;
311			print STDOUT "INFO ($type): $message", "\n" ;
312			}
313			}
314
315			sub traceEntry {
316			my $entry_source = shift;
317			my $entry_target = shift;
318			my $options = shift;
319
320			my $logfile = '../log/transfer.log';
321			if ($options->{error}) {
322			$logfile = '../log/errors.log';
323			}
324
325			my $dump_source = Dumper($entry_source);
326
327			#my $dump_target = Dumper($entry_target);
328			my $dump_target = "\n";
329			foreach my $attr ($entry_target->attributes) {
330			my $subentry = $attr . ": ";
331			my @value = $entry_target->get_value($attr);
332			if ($#value > 0) {
333			#push @value, "\n ";
334			$subentry .= "\n ";
335			}
336			$subentry .= join("\n ", @value);
337			$dump_target .= $subentry . "\n";
338			}
339
340			my $dump = <<EOD;
341			$hr
342			MAPI-Object:
343			$dump_source
344			$hr
345			Net::LDAP::Entry:
346			$dump_target
347			$hr
348			EOD
349
350			$dump = $hr . $options->{prefix} . $dump if $options->{prefix};
351
352			a2f($logfile, $dump);
353
354			}
355
356			sub toUTF8 {
357			my $string = shift;
358			#return to_utf8( -string => $string, -charset => 'ISO-8859-1');
359			print "before: $string", "\n";
360			var2utf8(\$string);
361			print "after: $string", "\n";
362			return $string;
363			}
364
365			sub readFieldMapping {
366			my $mapfile = shift;
367			if (! -e $mapfile) {
368			print "mapfile \"$mapfile\" does not exist.", "\n";
369			exit;
370			}
371			open(FH, '<', $mapfile);
372			while(<FH>) {
373			s/\r\n/\n/g;
374			chomp();
375			next if (m/^#/);
376			my @entry = split(';', $_);
377			my $key = $entry[0];
378			my $key_ldap = $entry[1];
379			$key_ldap \|\|= '';
380			$map->{mapi}{$key} = 1;
381			$map->{ldap}{$key} = $key_ldap;
382			}
383			close(FH);
384			}
385
386			sub createOuSafe {
387
388			#my $basedn = shift;
389			#my $cn = shift;
390
391			#my $dn = 'cn=' . $cn . ', ' . $basedn;
392			my $dn = shift;
393
394			#print "orig-dn: $dn", "\n";
395
396			$dn =~ m/ou=([\w\|\.]+?)[,\|].*/;
397			my $ou = $1;
398			#print "ou: '$ou'", "\n";
399
400			my $basedn = $dn;
401			$basedn =~ s/ou=$ou, //;
402			#print "basedn: $basedn", "\n";
403			#exit;
404
405			print "checking ou: (basedn='$basedn', ou='$ou')", "\n" if $DEBUGLEVEL > 3;
406			# if (checkOu($basedn, $ou)) {
407			if (existsEntry('ou', $dn)) {
408			return $dn;
409			}
410
411			if (my @ou_address = split(/\./, $ou)) {
412			return createDeepOu($basedn, \@ou_address);
413			} else {
414			return createOu($dn, $ou);
415			}
416
417			}
418
419			sub createDeepOu {
420			my $basedn = shift;
421			my $ou_address = shift;
422			my $dn = $basedn;
423			print "creating deep ou (basedn='$basedn')", "\n" if $DEBUGLEVEL > 3;
424			foreach (@$ou_address) {
425			my $ou = $_;
426			#print "ou: $ou", "\n";
427			$dn = "ou=$ou, " . $dn;
428			#print "dn: $dn", "\n";
429			createOu($dn, $ou);
430			}
431			return $dn;
432			}
433
434			sub createOu {
435			my $dn = shift;
436			my $ou = shift;
437			print "creating ou (DN='$dn', OU='$ou')", "\n" if $DEBUGLEVEL > 3;
438			my $entry = Net::LDAP::Entry->new;
439			$entry->dn($dn);
440			$entry->add(
441			#cn => $cn,
442			ou => $ou,
443			objectClass => 'organizationalUnit',
444			);
445			my $result = $entry->update($ldap);
446			#return $result;
447			return $dn;
448			}
449
450			sub checkOu {
451			my $basedn = shift;
452			my $ou = shift;
453
454			my $mesg = $ldap->search ( # perform a search
455			base => $basedn,
456			filter => "(&(ou=$ou))"
457			);
458
459			#print "search-result-code: ", $mesg->code, "\n";
460			#print "search-result-error: ", $mesg->error, "\n";
461
462			#return;
463			#print Dumper($mesg);
464			#exit;
465
466			#$mesg->code && die $mesg->error;
467
468			return 1 if exists $mesg->{entries};
469
470			}
471
472			sub existsEntry {
473
474			my $ldapType = shift;
475			my $dn = shift;
476
477			my $filter = "$ldapType =*";
478			#print "using filter: '$filter'", "\n";
479
480			# get part from full LDAP-address
481			#print "dn: $dn", "\n";
482			#$dn =~ m/$ldapType=([\w\|\.\| ]+?)[,\|].*/;
483			#my $part = $1;
484
485			# cut part
486			#print "ldapType: $ldapType", "\n";
487			#print "part: $part", "\n";
488			#$dn =~ s/$ldapType=$part, //;
489
490			# TODO:
491			# - split 'ou' or 'cn' from 'dn' here to create a search-attribute (one) and a $basedn (a parent node)
492			# - run search with $filter = 'ou\|cn =*' (<part-from-regex>) and $basedn=(<rest-from-regex>)
493
494			$filter = "(objectClass=*)";
495			#print "searching for dn='$dn' with filter='$filter'", "\n";
496			my $mesg = $ldap->search ( # perform a search
497			base => $dn,
498			filter => $filter,
499			# filter => "(&(ou=*))"
500			);
501
502			#print "search-result-code: ", $mesg->code, "\n";
503			#print "search-result-error: ", $mesg->error, "\n";
504
505			#return;
506			#print Dumper($mesg);
507			#exit;
508
509			#$mesg->code && die $mesg->error;
510
511			return 1 if exists $mesg->{entries};
512			return 0;
513
514			}
515
516			sub buildSnCn {
517			my $parts = shift;
518
519			my $logmsg;
520
521			my $cn;
522
523			if ($parts->{LastName}) {
524			# use pure "sn" first!
525			$cn = $parts->{LastName} ;
526
527			# add "givenname" to "cn" if exists
528			$cn = $parts->{FirstName} . ' ' . $cn if $parts->{FirstName};
529			}
530
531			# check if "cn" is already filled, else provide some fallback-mechanism(s) here
532			# use "FileAs"
533			if (!$cn && $parts->{FileAs}) {
534			$cn = $parts->{FileAs};
535			$logmsg = "using \"FileAs\" for \"cn\": $cn";
536			}
537			# use "FirstName"
538			if (!$cn && $parts->{FirstName}) {
539			$cn = $parts->{FirstName};
540			$logmsg = "using \"FirstName\" for \"cn\": $cn";
541			}
542			# use "CompanyName"
543			if (!$cn && $parts->{CompanyName}) {
544			$cn = $parts->{CompanyName};
545			$logmsg = "using \"CompanyName\" for \"cn\": $cn";
546			}
547
548			# handle "must-have"-field "sn"
549			my $sn = $parts->{LastName};
550
551			# additional (last) rule: use unique identifier (EntryID) as "cn" if it's still empty
552			#$cn = 'ident - ' . $parts->{EntryID} if !$cn;
553			if (!$cn) {
554			$cn = $parts->{EntryID};
555			$logmsg = "\"cn\" was empty, using EntryID.\n - cn: $cn";
556			}
557
558			# fallback to "cn" if "sn" is empty
559			$sn = $cn if !$sn;
560
561			# check for collisions in "cn"s
562			if (dnAlreadyUsed($cn)) {
563			#logError('App', "Couldn't use cn='$cn' - already exists!");
564			#return;
565			$cn .= '-' . $parts->{EntryID};
566			$logmsg .= "\n - modified \"cn\" to prevent name-collision.\n - cn: $cn";
567			}
568
569			#$msgCache->{} = $logmsg;
570			logInfo('App::buildCn', $logmsg) if $logmsg;
571
572			return { sn => $sn, cn => $cn, info => $logmsg };
573
574			}
575
576			sub buildDn {
577			my $parts = shift;
578
579			# build "dn"
580			my $dn = join(', ', "cn=" . $parts->{cn}, $parts->{basedn});
581
582			# patch dn (remove forbidden characters)
583			$dn =~ s/\+/&/g;
584
585			return $dn;
586			}
587
588			sub clearDnCache {
589			$dnCache = {};
590			$msgCache = {};
591			}
592
593			sub addDnCache {
594			my $key = shift;
595			$dnCache->{$key}++;
596			}
597
598			sub dnAlreadyUsed {
599			my $key = shift;
600			return exists $dnCache->{$key};
601			}
602
603			sub rememberCriticalEntry {
604			my $type = shift;
605			my $identifier = shift;
606			push @$criticalCache, { type => $type, identifier => $identifier };
607			}
608
609			sub showCriticalEntries {
610			return if !$criticalCache;
611			my @criticals = @$criticalCache;
612			if ($#criticals != -1) {
613			print "=" x 60, "\n";
614			print "Some errors occoured while processing data, show details? (y\|n) ";
615			my $answer = <STDIN>;
616			print "\n";
617			if ($answer =~ m/^y/i) {
618			foreach (@criticals) {
619			#print join("\n", @criticals);
620			#print Dumper($_);
621			print $_->{type}, ": ", $_->{identifier}, "\n";
622			print " ", $msgCache->{$_->{identifier}}, "\n";
623			delete $msgCache->{$_->{identifier}};
624			}
625			}
626			}
627			}
628
629			sub showGoodEntries {
630			print "=" x 60, "\n";
631			print "Show good entries? (y\|n) ";
632			my $answer = <STDIN>;
633			print "\n";
634			if ($answer =~ m/^y/i) {
635			foreach (keys %$msgCache) {
636			print $_, ": ", $msgCache->{$_}, "\n" if $msgCache->{$_};
637			}
638			}
639			}
640
641			sub processResult {
642
643			my $dn = shift;
644			my $result = shift;
645
646			#print "dn: $dn", "\n";
647			#print Dumper($result);
648
649			my $error = 0;
650			my $error_code;
651			my $error_message;
652			if ($result) {
653			$error_code = $result->code;
654			$error_message = $result->error;
655			} else {
656			$error_code = 'n/a';
657			$error_message = "NO RESULT FROM LDAP-SERVER";
658			}
659
660			if ($error_code) {
661			rememberCriticalEntry("ldap", $dn);
662			my $errmesg = "(error=$error_message, code=$error_code)";
663			rememberMessage($dn, $errmesg);
664			logError("LDAP", $errmesg, { dn => $dn } );
665			$error = 1;
666			} else {
667			print "SUCCESS for (dn='$dn')", "\n" if $DEBUGLEVEL > 1;
668			}
669
670			undef $result;
671			}
672
673			sub rememberMessage {
674			my $ident = shift;
675			my $mesg = shift;
676			$msgCache->{$ident} = $mesg;
677			}
678
679			1;
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26