extract virtual LDAP part from A3C
authorDobrica Pavlinusic <dpavlin@rot13.org>
Sat, 14 Mar 2009 13:01:20 +0000 (13:01 +0000)
committerDobrica Pavlinusic <dpavlin@rot13.org>
Sat, 14 Mar 2009 13:01:20 +0000 (13:01 +0000)
Makefile.PL [new file with mode: 0644]
bin/virtual-ldap.pl [new file with mode: 0755]
lib/VLDAP/Server.pm [new file with mode: 0644]

diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644 (file)
index 0000000..57202c4
--- /dev/null
@@ -0,0 +1,14 @@
+use inc::Module::Install;
+
+name        'VLDAP';
+version     '0.00';
+license     'GPL';
+
+requires       'Net::LDAP::Server';
+requires       'URI::Escape';
+requires       'IO::Socket::INET';
+requires    'Data::Dump';
+
+auto_install;
+
+WriteAll;
diff --git a/bin/virtual-ldap.pl b/bin/virtual-ldap.pl
new file mode 100755 (executable)
index 0000000..d7dc738
--- /dev/null
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib 'lib';
+use VLDAP::Server;
+
+VLDAP::Server->run({ port => 1389 });
+
+1;
diff --git a/lib/VLDAP/Server.pm b/lib/VLDAP/Server.pm
new file mode 100644 (file)
index 0000000..56094ba
--- /dev/null
@@ -0,0 +1,248 @@
+package VLDAP::Server;
+
+use strict;
+use warnings;
+
+use Net::LDAP::Constant qw(
+       LDAP_SUCCESS
+       LDAP_STRONG_AUTH_NOT_SUPPORTED
+       LDAP_UNAVAILABLE
+       LDAP_OPERATIONS_ERROR
+);
+use Net::LDAP::Server;
+use Net::LDAP::Filter;
+use base qw(Net::LDAP::Server);
+use fields qw(upstream);
+
+use URI::Escape;       # uri_escape
+use IO::Socket::INET;
+use IO::Select;
+
+use Data::Dump qw/dump/;
+
+=head1 NAME
+
+A3C::LDAP::Server
+
+=cut
+
+=head1 DESCRIPTION
+
+Provide LDAP server functionality for L<A3C> somewhat similar to C<slapo-rwm>
+
+=head1 METHODS
+
+=head2 run
+
+  my $pid = A3C::LDAP::Server->run({ port => 1389, fork => 0 });
+
+=cut
+
+our $pids;
+our $cache;
+
+sub cache {
+       return $cache if $cache;
+       $cache = new A3C::Cache->new({ instance => '', dir => 'ldap' });
+}
+
+sub run {
+       my $self = shift;
+
+       my $args = shift;
+       # default LDAP port
+       my $port = $args->{port} ||= 1389;
+
+       if ( $args->{fork} ) {
+               defined(my $pid = fork()) or die "Can't fork: $!";
+               if ( $pid ) {
+                       $pids->{ $port } = $pid;
+                       warn "# pids = ",dump( $pids );
+                       sleep 1;
+                       return $pid;
+               }
+       }
+
+       my $sock = IO::Socket::INET->new(
+               Listen => 5,
+               Proto => 'tcp',
+               Reuse => 1,
+               LocalPort => $port,
+       ) or die "can't listen on port $port: $!\n";
+
+       warn "LDAP server listening on port $port\n";
+
+       my $sel = IO::Select->new($sock) or die "can't select socket: $!\n";
+       my %Handlers;
+       while (my @ready = $sel->can_read) {
+               foreach my $fh (@ready) {
+                       if ($fh == $sock) {
+                               # let's create a new socket
+                               my $psock = $sock->accept;
+                               $sel->add($psock);
+                               $Handlers{*$psock} = A3C::LDAP::Server->new($psock);
+                       } else {
+                               my $result = $Handlers{*$fh}->handle;
+                               if ($result) {
+                                       # we have finished with the socket
+                                       $sel->remove($fh);
+                                       $fh->close;
+                                       delete $Handlers{*$fh};
+                               }
+                       }
+               }
+       }
+}
+
+=head2 stop
+
+  my $stopped_pids = A3C::LDAP::Server->stop;
+
+=cut
+
+sub stop {
+       warn "## stop pids = ",dump( $pids );
+       return unless $pids;
+       my $stopped = 0;
+       foreach my $port ( keys %$pids ) {
+               my $pid = delete($pids->{$port}) or die "no pid?";
+               warn "# Shutdown LDAP server at port $port pid $pid\n";
+               kill(9,$pid) or die "can't kill $pid: $!";
+               waitpid($pid,0) or die "waitpid $pid: $!";
+               $stopped++;
+       }
+       warn "## stopped $stopped processes\n";
+       return $stopped;
+}
+
+use constant RESULT_OK => {
+       'matchedDN' => '',
+       'errorMessage' => '',
+       'resultCode' => LDAP_SUCCESS
+};
+
+# constructor
+sub new {
+       my ($class, $sock) = @_;
+       my $self = $class->SUPER::new($sock);
+       printf "Accepted connection from: %s\n", $sock->peerhost();
+       return $self;
+}
+
+# the bind operation
+sub bind {
+       my ($self,$req) = @_;
+
+       warn "## bind req = ",dump($req);
+
+       defined($req->{authentication}->{simple}) or return {
+               matchedDN => '',
+               errorMessage => '',
+               resultCode => LDAP_STRONG_AUTH_NOT_SUPPORTED,
+       };
+
+       $self->{upstream} ||= A3C::LDAP->new->ldap or return {
+               matchedDN => '',
+               errorMessage => $@,
+               resultCode => LDAP_UNAVAILABLE,
+       };
+
+#      warn "## upstream = ",dump( $self->{upstream} );
+#      warn "upstream not Net::LDAP but ",ref($self->{upstream}) unless ref($self->{upstream}) eq 'Net::LDAP';
+
+       my $msg;
+
+       # FIXME we would need to unbind because A3C::LDAP binds us automatically, but that doesn't really work
+       #$msg = $self->{upstream}->unbind;
+       #warn "# unbind msg = ",dump( $msg );
+
+       $msg = $self->{upstream}->bind(
+               dn => $req->{name},
+               password => $req->{authentication}->{simple}
+       );
+
+       #warn "# bind msg = ",dump( $msg );
+       if ( $msg->code != LDAP_SUCCESS ) {
+               warn "ERROR: ", $msg->code, ": ", $msg->server_error, "\n";
+               return {
+                       matchedDN => '',
+                       errorMessage => $msg->server_error,
+                       resultCode => $msg->code,
+               };
+       }
+
+       return RESULT_OK;
+}
+
+# the search operation
+sub search {
+       my ($self,$req) = @_;
+
+       warn "## search req = ",dump( $req );
+
+       if ( ! $self->{upstream} ) {
+               warn "search without bind";
+               return {
+                       matchedDN => '',
+                       errorMessage => 'dude, bind first',
+                       resultCode => LDAP_OPERATIONS_ERROR,
+               };
+       }
+
+       my $filter;
+       if (defined $req->{filter}) {
+               # $req->{filter} is a ASN1-decoded tree; luckily, this is exactly the
+               # internal representation Net::LDAP::Filter uses.  [FIXME] Eventually
+               # Net::LDAP::Filter should provide a corresponding constructor.
+               bless($req->{filter}, 'Net::LDAP::Filter');
+               $filter = $req->{filter}->as_string;
+#              $filter = '(&' . $req->{filter}->as_string
+#                                         . '(objectClass=hrEduPerson)(host=aai.irb.hr))';
+       }
+
+       warn "search upstream for $filter\n";
+
+       my $search = $self->{upstream}->search(
+               base => $req->{baseObject},
+               scope => $req->{scope},
+               deref => $req->{derefAliases},
+               sizelimit => $req->{sizeLimit},
+               timelimit => $req->{timeLimit},
+               typesonly => $req->{typesOnly},
+               filter => $filter,
+               attrs => $req->{attributes},
+               raw => qr/.*/,
+       );
+
+#      warn "# search = ",dump( $search );
+
+       if ( $search->code != LDAP_SUCCESS ) {
+               warn "ERROR: ",$search->code,": ",$search->server_error;
+               return {
+                       matchedDN => '',
+                       errorMessage => $search->server_error,
+                       resultCode => $search->code,
+               };
+       };
+
+       my @entries = $search->entries;
+       warn "## got ", $search->count, " entries for $filter\n";
+       foreach my $entry (@entries) {
+#              $entry->changetype('add');  # Don't record changes.
+#              foreach my $attr ($entry->attributes) {
+#                      if ($attr =~ /;lang-en$/) { 
+#                              $entry->delete($attr);
+#                      }
+#              }
+       }
+
+       warn "## entries = ",dump( @entries );
+
+       $self->cache->write_cache( \@entries, uri_escape( $filter ));
+
+       return RESULT_OK, @entries;
+}
+
+# the rest of the operations will return an "unwilling to perform"
+
+1;