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