git.rot13.org Git - virtual-ldap/blob - lib/VLDAP/Server.pm

   1 package VLDAP::Server;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Net::LDAP::Constant qw(
   7         LDAP_SUCCESS
   8         LDAP_STRONG_AUTH_NOT_SUPPORTED
   9         LDAP_UNAVAILABLE
  10         LDAP_OPERATIONS_ERROR
  11 );
  12 use Net::LDAP::Server;
  13 use Net::LDAP::Filter;
  14 use base qw(Net::LDAP::Server);
  15 use fields qw(upstream);
  16
  17 use URI::Escape;        # uri_escape
  18 use IO::Socket::INET;
  19 use IO::Select;
  20
  21 use Data::Dump qw/dump/;
  22
  23 =head1 NAME
  24
  25 A3C::LDAP::Server
  26
  27 =cut
  28
  29 =head1 DESCRIPTION
  30
  31 Provide LDAP server functionality for L<A3C> somewhat similar to C<slapo-rwm>
  32
  33 =head1 METHODS
  34
  35 =head2 run
  36
  37   my $pid = A3C::LDAP::Server->run({ port => 1389, fork => 0 });
  38
  39 =cut
  40
  41 our $pids;
  42 our $cache;
  43
  44 sub cache {
  45         return $cache if $cache;
  46         $cache = new A3C::Cache->new({ instance => '', dir => 'ldap' });
  47 }
  48
  49 sub run {
  50         my $self = shift;
  51
  52         my $args = shift;
  53         # default LDAP port
  54         my $port = $args->{port} ||= 1389;
  55
  56         if ( $args->{fork} ) {
  57                 defined(my $pid = fork()) or die "Can't fork: $!";
  58                 if ( $pid ) {
  59                         $pids->{ $port } = $pid;
  60                         warn "# pids = ",dump( $pids );
  61                         sleep 1;
  62                         return $pid;
  63                 }
  64         }
  65
  66         my $sock = IO::Socket::INET->new(
  67                 Listen => 5,
  68                 Proto => 'tcp',
  69                 Reuse => 1,
  70                 LocalPort => $port,
  71         ) or die "can't listen on port $port: $!\n";
  72
  73         warn "LDAP server listening on port $port\n";
  74
  75         my $sel = IO::Select->new($sock) or die "can't select socket: $!\n";
  76         my %Handlers;
  77         while (my @ready = $sel->can_read) {
  78                 foreach my $fh (@ready) {
  79                         if ($fh == $sock) {
  80                                 # let's create a new socket
  81                                 my $psock = $sock->accept;
  82                                 $sel->add($psock);
  83                                 $Handlers{*$psock} = A3C::LDAP::Server->new($psock);
  84                         } else {
  85                                 my $result = $Handlers{*$fh}->handle;
  86                                 if ($result) {
  87                                         # we have finished with the socket
  88                                         $sel->remove($fh);
  89                                         $fh->close;
  90                                         delete $Handlers{*$fh};
  91                                 }
  92                         }
  93                 }
  94         }
  95 }
  96
  97 =head2 stop
  98
  99   my $stopped_pids = A3C::LDAP::Server->stop;
 100
 101 =cut
 102
 103 sub stop {
 104         warn "## stop pids = ",dump( $pids );
 105         return unless $pids;
 106         my $stopped = 0;
 107         foreach my $port ( keys %$pids ) {
 108                 my $pid = delete($pids->{$port}) or die "no pid?";
 109                 warn "# Shutdown LDAP server at port $port pid $pid\n";
 110                 kill(9,$pid) or die "can't kill $pid: $!";
 111                 waitpid($pid,0) or die "waitpid $pid: $!";
 112                 $stopped++;
 113         }
 114         warn "## stopped $stopped processes\n";
 115         return $stopped;
 116 }
 117
 118 use constant RESULT_OK => {
 119         'matchedDN' => '',
 120         'errorMessage' => '',
 121         'resultCode' => LDAP_SUCCESS
 122 };
 123
 124 # constructor
 125 sub new {
 126         my ($class, $sock) = @_;
 127         my $self = $class->SUPER::new($sock);
 128         printf "Accepted connection from: %s\n", $sock->peerhost();
 129         return $self;
 130 }
 131
 132 # the bind operation
 133 sub bind {
 134         my ($self,$req) = @_;
 135
 136         warn "## bind req = ",dump($req);
 137
 138         defined($req->{authentication}->{simple}) or return {
 139                 matchedDN => '',
 140                 errorMessage => '',
 141                 resultCode => LDAP_STRONG_AUTH_NOT_SUPPORTED,
 142         };
 143
 144         $self->{upstream} ||= A3C::LDAP->new->ldap or return {
 145                 matchedDN => '',
 146                 errorMessage => $@,
 147                 resultCode => LDAP_UNAVAILABLE,
 148         };
 149
 150 #       warn "## upstream = ",dump( $self->{upstream} );
 151 #       warn "upstream not Net::LDAP but ",ref($self->{upstream}) unless ref($self->{upstream}) eq 'Net::LDAP';
 152
 153         my $msg;
 154
 155         # FIXME we would need to unbind because A3C::LDAP binds us automatically, but that doesn't really work
 156         #$msg = $self->{upstream}->unbind;
 157         #warn "# unbind msg = ",dump( $msg );
 158
 159         $msg = $self->{upstream}->bind(
 160                 dn => $req->{name},
 161                 password => $req->{authentication}->{simple}
 162         );
 163
 164         #warn "# bind msg = ",dump( $msg );
 165         if ( $msg->code != LDAP_SUCCESS ) {
 166                 warn "ERROR: ", $msg->code, ": ", $msg->server_error, "\n";
 167                 return {
 168                         matchedDN => '',
 169                         errorMessage => $msg->server_error,
 170                         resultCode => $msg->code,
 171                 };
 172         }
 173
 174         return RESULT_OK;
 175 }
 176
 177 # the search operation
 178 sub search {
 179         my ($self,$req) = @_;
 180
 181         warn "## search req = ",dump( $req );
 182
 183         if ( ! $self->{upstream} ) {
 184                 warn "search without bind";
 185                 return {
 186                         matchedDN => '',
 187                         errorMessage => 'dude, bind first',
 188                         resultCode => LDAP_OPERATIONS_ERROR,
 189                 };
 190         }
 191
 192         my $filter;
 193         if (defined $req->{filter}) {
 194                 # $req->{filter} is a ASN1-decoded tree; luckily, this is exactly the
 195                 # internal representation Net::LDAP::Filter uses.  [FIXME] Eventually
 196                 # Net::LDAP::Filter should provide a corresponding constructor.
 197                 bless($req->{filter}, 'Net::LDAP::Filter');
 198                 $filter = $req->{filter}->as_string;
 199 #               $filter = '(&' . $req->{filter}->as_string
 200 #                                          . '(objectClass=hrEduPerson)(host=aai.irb.hr))';
 201         }
 202
 203         warn "search upstream for $filter\n";
 204
 205         my $search = $self->{upstream}->search(
 206                 base => $req->{baseObject},
 207                 scope => $req->{scope},
 208                 deref => $req->{derefAliases},
 209                 sizelimit => $req->{sizeLimit},
 210                 timelimit => $req->{timeLimit},
 211                 typesonly => $req->{typesOnly},
 212                 filter => $filter,
 213                 attrs => $req->{attributes},
 214                 raw => qr/.*/,
 215         );
 216
 217 #       warn "# search = ",dump( $search );
 218
 219         if ( $search->code != LDAP_SUCCESS ) {
 220                 warn "ERROR: ",$search->code,": ",$search->server_error;
 221                 return {
 222                         matchedDN => '',
 223                         errorMessage => $search->server_error,
 224                         resultCode => $search->code,
 225                 };
 226         };
 227
 228         my @entries = $search->entries;
 229         warn "## got ", $search->count, " entries for $filter\n";
 230         foreach my $entry (@entries) {
 231 #               $entry->changetype('add');  # Don't record changes.
 232 #               foreach my $attr ($entry->attributes) {
 233 #                       if ($attr =~ /;lang-en$/) {
 234 #                               $entry->delete($attr);
 235 #                       }
 236 #               }
 237         }
 238
 239         warn "## entries = ",dump( @entries );
 240
 241         $self->cache->write_cache( \@entries, uri_escape( $filter ));
 242
 243         return RESULT_OK, @entries;
 244 }
 245
 246 # the rest of the operations will return an "unwilling to perform"
 247
 248 1;