/[virtual-ldap]/lib/VLDAP/Server.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /lib/VLDAP/Server.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Sat Mar 14 13:01:20 2009 UTC (10 years, 7 months ago) by dpavlin
File size: 5430 byte(s)
extract virtual LDAP part from A3C
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;

  ViewVC Help
Powered by ViewVC 1.1.26