6 use Net::LDAP::Constant qw(
8 LDAP_STRONG_AUTH_NOT_SUPPORTED
12 use Net::LDAP::Server;
13 use Net::LDAP::Filter;
14 use base qw(Net::LDAP::Server);
15 use fields qw(upstream);
19 use URI::Escape; # uri_escape
23 use YAML qw/DumpFile/;
25 use Data::Dump qw/dump/;
35 Provide LDAP server functionality somewhat similar to C<slapo-rwm>
41 my $pid = LDAP::Virtual->run({ port => 1389, fork => 0 });
52 my $port = $args->{port} ||= 1389;
54 if ( $args->{fork} ) {
55 defined(my $pid = fork()) or die "Can't fork: $!";
57 $pids->{ $port } = $pid;
58 warn "# pids = ",dump( $pids );
64 my $sock = IO::Socket::INET->new(
69 ) or die "can't listen on port $port: $!\n";
71 warn "LDAP server listening on port $port\n";
73 my $sel = IO::Select->new($sock) or die "can't select socket: $!\n";
75 while (my @ready = $sel->can_read) {
76 foreach my $fh (@ready) {
78 # let's create a new socket
79 my $psock = $sock->accept;
81 $Handlers{*$psock} = LDAP::Virtual->new($psock);
83 my $result = $Handlers{*$fh}->handle;
85 # we have finished with the socket
88 delete $Handlers{*$fh};
97 my $stopped_pids = LDAP::Virtual->stop;
102 warn "## stop pids = ",dump( $pids );
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: $!";
112 warn "## stopped $stopped processes\n";
116 use constant RESULT_OK => {
118 'errorMessage' => '',
119 'resultCode' => LDAP_SUCCESS
124 my ($class, $sock) = @_;
125 my $self = $class->SUPER::new($sock);
126 printf "Accepted connection from: %s\n", $sock->peerhost();
132 my ($self,$req) = @_;
134 warn "## bind req = ",dump($req);
136 defined($req->{authentication}->{simple}) or return {
139 resultCode => LDAP_STRONG_AUTH_NOT_SUPPORTED,
142 $self->{upstream} ||= Net::LDAP->new( 'ldaps://ldap.ffzg.hr/' ) or return {
145 resultCode => LDAP_UNAVAILABLE,
148 warn "## upstream = ",dump( $self->{upstream} );
149 warn "upstream not Net::LDAP but ",ref($self->{upstream}) unless ref($self->{upstream}) eq 'Net::LDAP';
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 );
158 $bind->{dn} = $req->{name} if $req->{name};
160 if ( $bind->{dn} =~ m{@} ) {
162 $bind->{dn} =~ s/[@\.]/,dc=/g;
163 $bind->{dn} =~ s/^/uid=/;
167 $bind->{password} = $req->{authentication}->{simple} if $req->{authentication}->{simple};
168 warn "# bind ",dump( $bind );
169 $msg = $self->{upstream}->bind( %$bind );
171 #warn "# bind msg = ",dump( $msg );
172 if ( $msg->code != LDAP_SUCCESS ) {
173 warn "ERROR: ", $msg->code, ": ", $msg->server_error, "\n";
176 errorMessage => $msg->server_error,
177 resultCode => $msg->code,
184 # the search operation
186 my ($self,$req) = @_;
188 warn "## search req = ",dump( $req );
190 if ( ! $self->{upstream} ) {
191 warn "search without bind";
194 errorMessage => 'dude, bind first',
195 resultCode => LDAP_OPERATIONS_ERROR,
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))';
210 warn "search upstream for $filter\n";
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},
220 attrs => $req->{attributes},
224 # warn "# search = ",dump( $search );
226 if ( $search->code != LDAP_SUCCESS ) {
227 warn "ERROR: ",$search->code,": ",$search->server_error;
230 errorMessage => $search->server_error,
231 resultCode => $search->code,
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);
246 warn "## entries = ",dump( @entries );
248 my $path = 'var/' . uri_escape( $filter ) . '.yml';
249 DumpFile( $path, \@entries );
250 warn "# created $path ", -s $path, " bytes";
252 return RESULT_OK, @entries;
255 # the rest of the operations will return an "unwilling to perform"