git.rot13.org Git - virtual-ldap/blob - lib/LDAP/Virtual.pm

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