/[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

Annotation of /lib/VLDAP/Server.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (hide 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 dpavlin 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