/[A3C]/lib/A3C/LDAP/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/A3C/LDAP/Server.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 229 - (show annotations)
Fri Jun 27 19:31:49 2008 UTC (15 years, 9 months ago) by dpavlin
File size: 5445 byte(s)
A3C::LDAP::Server now function as full-featured LDAP relay server

- move code from bin/ldap-server.pl to A3C::LDAP::Server
- save cache of ldap searches (currently for debugging only,
  but I can envision falling back to cache if upstream
  server is unavailable)
- added ability to fork server in background (used in tests)
1 package A3C::LDAP::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 A3C::LDAP;
18 use A3C::Cache;
19
20 #use A3C::Cache;
21 use URI::Escape; # uri_escape
22
23 use Data::Dump qw/dump/;
24
25 =head1 NAME
26
27 A3C::LDAP::Server
28
29 =cut
30
31 =head1 DESCRIPTION
32
33 Provide LDAP server functionality for L<A3C> somewhat similar to C<slapo-rwm>
34
35 =head1 METHODS
36
37 =head2 run
38
39 my $pid = A3C::LDAP::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} = A3C::LDAP::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 = A3C::LDAP::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} ||= A3C::LDAP->new->ldap 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 A3C::LDAP binds us automatically, but that doesn't really work
158 #$msg = $self->{upstream}->unbind;
159 #warn "# unbind msg = ",dump( $msg );
160
161 $msg = $self->{upstream}->bind(
162 dn => $req->{name},
163 password => $req->{authentication}->{simple}
164 );
165
166 #warn "# bind msg = ",dump( $msg );
167 if ( $msg->code != LDAP_SUCCESS ) {
168 warn "ERROR: ", $msg->code, ": ", $msg->server_error, "\n";
169 return {
170 matchedDN => '',
171 errorMessage => $msg->server_error,
172 resultCode => $msg->code,
173 };
174 }
175
176 return RESULT_OK;
177 }
178
179 # the search operation
180 sub search {
181 my ($self,$req) = @_;
182
183 warn "## search req = ",dump( $req );
184
185 if ( ! $self->{upstream} ) {
186 warn "search without bind";
187 return {
188 matchedDN => '',
189 errorMessage => 'dude, bind first',
190 resultCode => LDAP_OPERATIONS_ERROR,
191 };
192 }
193
194 my $filter;
195 if (defined $req->{filter}) {
196 # $req->{filter} is a ASN1-decoded tree; luckily, this is exactly the
197 # internal representation Net::LDAP::Filter uses. [FIXME] Eventually
198 # Net::LDAP::Filter should provide a corresponding constructor.
199 bless($req->{filter}, 'Net::LDAP::Filter');
200 $filter = $req->{filter}->as_string;
201 # $filter = '(&' . $req->{filter}->as_string
202 # . '(objectClass=hrEduPerson)(host=aai.irb.hr))';
203 }
204
205 warn "search upstream for $filter\n";
206
207 my $search = $self->{upstream}->search(
208 base => $req->{baseObject},
209 scope => $req->{scope},
210 deref => $req->{derefAliases},
211 sizelimit => $req->{sizeLimit},
212 timelimit => $req->{timeLimit},
213 typesonly => $req->{typesOnly},
214 filter => $filter,
215 attrs => $req->{attributes},
216 raw => qr/.*/,
217 );
218
219 # warn "# search = ",dump( $search );
220
221 if ( $search->code != LDAP_SUCCESS ) {
222 warn "ERROR: ",$search->code,": ",$search->server_error;
223 return {
224 matchedDN => '',
225 errorMessage => $search->server_error,
226 resultCode => $search->code,
227 };
228 };
229
230 my @entries = $search->entries;
231 warn "## got ", $search->count, " entries for $filter\n";
232 foreach my $entry (@entries) {
233 # $entry->changetype('add'); # Don't record changes.
234 # foreach my $attr ($entry->attributes) {
235 # if ($attr =~ /;lang-en$/) {
236 # $entry->delete($attr);
237 # }
238 # }
239 }
240
241 warn "## entries = ",dump( @entries );
242
243 $self->cache->write_cache( \@entries, uri_escape( $filter ));
244
245 return RESULT_OK, @entries;
246 }
247
248 # the rest of the operations will return an "unwilling to perform"
249
250 1;

  ViewVC Help
Powered by ViewVC 1.1.26