A3C/LDAP/Server.pm

package A3C::LDAP::Server;

use strict;
use warnings;

use Net::LDAP::Constant qw(
        LDAP_SUCCESS
        LDAP_STRONG_AUTH_NOT_SUPPORTED
        LDAP_UNAVAILABLE
        LDAP_OPERATIONS_ERROR
);
use Net::LDAP::Server;
use Net::LDAP::Filter;
use base qw(Net::LDAP::Server);
use fields qw(upstream);

use A3C::LDAP;
use A3C::Cache;

#use A3C::Cache;
use URI::Escape;        # uri_escape

use Data::Dump qw/dump/;

=head1 NAME

A3C::LDAP::Server

=cut

=head1 DESCRIPTION

Provide LDAP server functionality for L<A3C> somewhat similar to C<slapo-rwm>

=head1 METHODS

=head2 run

  my $pid = A3C::LDAP::Server->run({ port => 1389, fork => 0 });

=cut

our $pids;
our $cache;

sub cache {
        return $cache if $cache;
        $cache = new A3C::Cache->new({ instance => '', dir => 'ldap' });
}

sub run {
        my $self = shift;

        my $args = shift;
        # default LDAP port
        my $port = $args->{port} ||= 1389;

        if ( $args->{fork} ) {
                defined(my $pid = fork()) or die "Can't fork: $!";
                if ( $pid ) {
                        $pids->{ $port } = $pid;
                        warn "# pids = ",dump( $pids );
                        sleep 1;
                        return $pid;
                }
        }

        my $sock = IO::Socket::INET->new(
                Listen => 5,
                Proto => 'tcp',
                Reuse => 1,
                LocalPort => $port,
        ) or die "can't listen on port $port: $!\n";

        warn "LDAP server listening on port $port\n";

        my $sel = IO::Select->new($sock) or die "can't select socket: $!\n";
        my %Handlers;
        while (my @ready = $sel->can_read) {
                foreach my $fh (@ready) {
                        if ($fh == $sock) {
                                # let's create a new socket
                                my $psock = $sock->accept;
                                $sel->add($psock);
                                $Handlers{*$psock} = A3C::LDAP::Server->new($psock);
                        } else {
                                my $result = $Handlers{*$fh}->handle;
                                if ($result) {
                                        # we have finished with the socket
                                        $sel->remove($fh);
                                        $fh->close;
                                        delete $Handlers{*$fh};
                                }
                        }
                }
        }
}

=head2 stop

  my $stopped_pids = A3C::LDAP::Server->stop;

=cut

sub stop {
        warn "## stop pids = ",dump( $pids );
        return unless $pids;
        my $stopped = 0;
        foreach my $port ( keys %$pids ) {
                my $pid = delete($pids->{$port}) or die "no pid?";
                warn "# Shutdown LDAP server at port $port pid $pid\n";
                kill(9,$pid) or die "can't kill $pid: $!";
                waitpid($pid,0) or die "waitpid $pid: $!";
                $stopped++;
        }
        warn "## stopped $stopped processes\n";
        return $stopped;
}

use constant RESULT_OK => {
        'matchedDN' => '',
        'errorMessage' => '',
        'resultCode' => LDAP_SUCCESS
};

# constructor
sub new {
        my ($class, $sock) = @_;
        my $self = $class->SUPER::new($sock);
        printf "Accepted connection from: %s\n", $sock->peerhost();
        return $self;
}

# the bind operation
sub bind {
        my ($self,$req) = @_;

        warn "## bind req = ",dump($req);

        defined($req->{authentication}->{simple}) or return {
                matchedDN => '',
                errorMessage => '',
                resultCode => LDAP_STRONG_AUTH_NOT_SUPPORTED,
        };

        $self->{upstream} ||= A3C::LDAP->new->ldap or return {
                matchedDN => '',
                errorMessage => $@,
                resultCode => LDAP_UNAVAILABLE,
        };

#       warn "## upstream = ",dump( $self->{upstream} );
#       warn "upstream not Net::LDAP but ",ref($self->{upstream}) unless ref($self->{upstream}) eq 'Net::LDAP';

        my $msg;

        # FIXME we would need to unbind because A3C::LDAP binds us automatically, but that doesn't really work
        #$msg = $self->{upstream}->unbind;
        #warn "# unbind msg = ",dump( $msg );

        $msg = $self->{upstream}->bind(
                dn => $req->{name},
                password => $req->{authentication}->{simple}
        );

        #warn "# bind msg = ",dump( $msg );
        if ( $msg->code != LDAP_SUCCESS ) {
                warn "ERROR: ", $msg->code, ": ", $msg->server_error, "\n";
                return {
                        matchedDN => '',
                        errorMessage => $msg->server_error,
                        resultCode => $msg->code,
                };
        }

        return RESULT_OK;
}

# the search operation
sub search {
        my ($self,$req) = @_;

        warn "## search req = ",dump( $req );

        if ( ! $self->{upstream} ) {
                warn "search without bind";
                return {
                        matchedDN => '',
                        errorMessage => 'dude, bind first',
                        resultCode => LDAP_OPERATIONS_ERROR,
                };
        }

        my $filter;
        if (defined $req->{filter}) {
                # $req->{filter} is a ASN1-decoded tree; luckily, this is exactly the
                # internal representation Net::LDAP::Filter uses.  [FIXME] Eventually
                # Net::LDAP::Filter should provide a corresponding constructor.
                bless($req->{filter}, 'Net::LDAP::Filter');
                $filter = $req->{filter}->as_string;
#               $filter = '(&' . $req->{filter}->as_string
#                                          . '(objectClass=hrEduPerson)(host=aai.irb.hr))';
        }

        warn "search upstream for $filter\n";

        my $search = $self->{upstream}->search(
                base => $req->{baseObject},
                scope => $req->{scope},
                deref => $req->{derefAliases},
                sizelimit => $req->{sizeLimit},
                timelimit => $req->{timeLimit},
                typesonly => $req->{typesOnly},
                filter => $filter,
                attrs => $req->{attributes},
                raw => qr/.*/,
        );

#       warn "# search = ",dump( $search );

        if ( $search->code != LDAP_SUCCESS ) {
                warn "ERROR: ",$search->code,": ",$search->server_error;
                return {
                        matchedDN => '',
                        errorMessage => $search->server_error,
                        resultCode => $search->code,
                };
        };

        my @entries = $search->entries;
        warn "## got ", $search->count, " entries for $filter\n";
        foreach my $entry (@entries) {
#               $entry->changetype('add');  # Don't record changes.
#               foreach my $attr ($entry->attributes) {
#                       if ($attr =~ /;lang-en$/) { 
#                               $entry->delete($attr);
#                       }
#               }
        }

        warn "## entries = ",dump( @entries );

        $self->cache->write_cache( \@entries, uri_escape( $filter ));

        return RESULT_OK, @entries;
}

# the rest of the operations will return an "unwilling to perform"

1;
1	dpavlin	222	package A3C::LDAP::Server;
2
3			use strict;
4			use warnings;
5
6	dpavlin	223	use Net::LDAP::Constant qw(
7			LDAP_SUCCESS
8			LDAP_STRONG_AUTH_NOT_SUPPORTED
9			LDAP_UNAVAILABLE
10			LDAP_OPERATIONS_ERROR
11			);
12	dpavlin	222	use Net::LDAP::Server;
13	dpavlin	223	use Net::LDAP::Filter;
14	dpavlin	229	use base qw(Net::LDAP::Server);
15	dpavlin	223	use fields qw(upstream);
16	dpavlin	222
17	dpavlin	223	use A3C::LDAP;
18	dpavlin	229	use A3C::Cache;
19
20			#use A3C::Cache;
21			use URI::Escape; # uri_escape
22
23	dpavlin	223	use Data::Dump qw/dump/;
24
25	dpavlin	225	=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	dpavlin	229	=head1 METHODS
36
37			=head2 run
38
39			my $pid = A3C::LDAP::Server->run({ port => 1389, fork => 0 });
40
41	dpavlin	225	=cut
42
43	dpavlin	229	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	dpavlin	222	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	dpavlin	223	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	dpavlin	224	# warn "## upstream = ",dump( $self->{upstream} );
153	dpavlin	223	# warn "upstream not Net::LDAP but ",ref($self->{upstream}) unless ref($self->{upstream}) eq 'Net::LDAP';
154
155	dpavlin	226	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	dpavlin	229	#warn "# bind msg = ",dump( $msg );
167	dpavlin	226	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	dpavlin	222	return RESULT_OK;
177			}
178
179			# the search operation
180			sub search {
181	dpavlin	223	my ($self,$req) = @_;
182	dpavlin	222
183	dpavlin	223	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	dpavlin	222	}
193	dpavlin	223
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	dpavlin	224	warn "search upstream for $filter\n";
206	dpavlin	223
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	dpavlin	224	# warn "# search = ",dump( $search );
220	dpavlin	223
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	dpavlin	224	warn "## got ", $search->count, " entries for $filter\n";
232	dpavlin	223	foreach my $entry (@entries) {
233	dpavlin	225	# $entry->changetype('add'); # Don't record changes.
234	dpavlin	223	# foreach my $attr ($entry->attributes) {
235			# if ($attr =~ /;lang-en$/) {
236			# $entry->delete($attr);
237			# }
238			# }
239			}
240
241			warn "## entries = ",dump( @entries );
242	dpavlin	229
243			$self->cache->write_cache( \@entries, uri_escape( $filter ));
244
245	dpavlin	222	return RESULT_OK, @entries;
246			}
247
248			# the rest of the operations will return an "unwilling to perform"
249
250			1;