lib/LDAP/Virtual.pm

package LDAP::Virtual;

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 Net::LDAP;

use URI::Escape;        # uri_escape
use IO::Socket::INET;
use IO::Select;

use YAML qw/DumpFile/;

use Data::Dump qw/dump/;

=head1 NAME

LDAP::Virtual

=cut

=head1 DESCRIPTION

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

=head1 METHODS

=head2 run

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

=cut

our $pids;

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} = LDAP::Virtual->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 = LDAP::Virtual->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} ||= Net::LDAP->new( 'ldaps://ldap.ffzg.hr/' ) 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 VLDAP binds us automatically, but that doesn't really work
        #$msg = $self->{upstream}->unbind;
        #warn "# unbind msg = ",dump( $msg );

        my $bind;
        $bind->{dn} = $req->{name} if $req->{name};

        if ( $bind->{dn} =~ m{@} ) {

                        $bind->{dn} =~ s/[@\.]/,dc=/g;
                        $bind->{dn} =~ s/^/uid=/;

        }

        $bind->{password} = $req->{authentication}->{simple} if $req->{authentication}->{simple};
        warn "# bind ",dump( $bind );
        $msg = $self->{upstream}->bind( %$bind );

        #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 );

        my $path = 'var/' . uri_escape( $filter ) . '.yml';
        DumpFile( $path, \@entries );
        warn "# created $path ", -s $path, " bytes";

        return RESULT_OK, @entries;
}

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

1;
1	dpavlin	4	package LDAP::Virtual;
2	dpavlin	1
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	dpavlin	2	use Net::LDAP;
18
19	dpavlin	1	use URI::Escape; # uri_escape
20			use IO::Socket::INET;
21			use IO::Select;
22
23	dpavlin	6	use YAML qw/DumpFile/;
24
25	dpavlin	1	use Data::Dump qw/dump/;
26
27			=head1 NAME
28
29	dpavlin	4	LDAP::Virtual
30	dpavlin	1
31			=cut
32
33			=head1 DESCRIPTION
34
35	dpavlin	2	Provide LDAP server functionality somewhat similar to C<slapo-rwm>
36	dpavlin	1
37			=head1 METHODS
38
39			=head2 run
40
41	dpavlin	4	my $pid = LDAP::Virtual->run({ port => 1389, fork => 0 });
42	dpavlin	1
43			=cut
44
45			our $pids;
46
47			sub run {
48			my $self = shift;
49
50			my $args = shift;
51			# default LDAP port
52			my $port = $args->{port} \|\|= 1389;
53
54			if ( $args->{fork} ) {
55			defined(my $pid = fork()) or die "Can't fork: $!";
56			if ( $pid ) {
57			$pids->{ $port } = $pid;
58			warn "# pids = ",dump( $pids );
59			sleep 1;
60			return $pid;
61			}
62			}
63
64			my $sock = IO::Socket::INET->new(
65			Listen => 5,
66			Proto => 'tcp',
67			Reuse => 1,
68			LocalPort => $port,
69			) or die "can't listen on port $port: $!\n";
70
71			warn "LDAP server listening on port $port\n";
72
73			my $sel = IO::Select->new($sock) or die "can't select socket: $!\n";
74			my %Handlers;
75			while (my @ready = $sel->can_read) {
76			foreach my $fh (@ready) {
77			if ($fh == $sock) {
78			# let's create a new socket
79			my $psock = $sock->accept;
80			$sel->add($psock);
81	dpavlin	4	$Handlers{*$psock} = LDAP::Virtual->new($psock);
82	dpavlin	1	} else {
83			my $result = $Handlers{*$fh}->handle;
84			if ($result) {
85			# we have finished with the socket
86			$sel->remove($fh);
87			$fh->close;
88			delete $Handlers{*$fh};
89			}
90			}
91			}
92			}
93			}
94
95			=head2 stop
96
97	dpavlin	4	my $stopped_pids = LDAP::Virtual->stop;
98	dpavlin	1
99			=cut
100
101			sub stop {
102			warn "## stop pids = ",dump( $pids );
103			return unless $pids;
104			my $stopped = 0;
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: $!";
110			$stopped++;
111			}
112			warn "## stopped $stopped processes\n";
113			return $stopped;
114			}
115
116			use constant RESULT_OK => {
117			'matchedDN' => '',
118			'errorMessage' => '',
119			'resultCode' => LDAP_SUCCESS
120			};
121
122			# constructor
123			sub new {
124			my ($class, $sock) = @_;
125			my $self = $class->SUPER::new($sock);
126			printf "Accepted connection from: %s\n", $sock->peerhost();
127			return $self;
128			}
129
130			# the bind operation
131			sub bind {
132			my ($self,$req) = @_;
133
134			warn "## bind req = ",dump($req);
135
136			defined($req->{authentication}->{simple}) or return {
137			matchedDN => '',
138			errorMessage => '',
139			resultCode => LDAP_STRONG_AUTH_NOT_SUPPORTED,
140			};
141
142	dpavlin	2	$self->{upstream} \|\|= Net::LDAP->new( 'ldaps://ldap.ffzg.hr/' ) or return {
143	dpavlin	1	matchedDN => '',
144			errorMessage => $@,
145			resultCode => LDAP_UNAVAILABLE,
146			};
147
148	dpavlin	2	warn "## upstream = ",dump( $self->{upstream} );
149			warn "upstream not Net::LDAP but ",ref($self->{upstream}) unless ref($self->{upstream}) eq 'Net::LDAP';
150	dpavlin	1
151			my $msg;
152
153	dpavlin	2	# FIXME we would need to unbind because VLDAP binds us automatically, but that doesn't really work
154	dpavlin	1	#$msg = $self->{upstream}->unbind;
155			#warn "# unbind msg = ",dump( $msg );
156
157	dpavlin	3	my $bind;
158			$bind->{dn} = $req->{name} if $req->{name};
159	dpavlin	59
160			if ( $bind->{dn} =~ m{@} ) {
161
162			$bind->{dn} =~ s/[@\.]/,dc=/g;
163			$bind->{dn} =~ s/^/uid=/;
164
165			}
166
167	dpavlin	3	$bind->{password} = $req->{authentication}->{simple} if $req->{authentication}->{simple};
168			warn "# bind ",dump( $bind );
169			$msg = $self->{upstream}->bind( %$bind );
170	dpavlin	1
171			#warn "# bind msg = ",dump( $msg );
172			if ( $msg->code != LDAP_SUCCESS ) {
173			warn "ERROR: ", $msg->code, ": ", $msg->server_error, "\n";
174			return {
175			matchedDN => '',
176			errorMessage => $msg->server_error,
177			resultCode => $msg->code,
178			};
179			}
180
181			return RESULT_OK;
182			}
183
184			# the search operation
185			sub search {
186			my ($self,$req) = @_;
187
188			warn "## search req = ",dump( $req );
189
190			if ( ! $self->{upstream} ) {
191			warn "search without bind";
192			return {
193			matchedDN => '',
194			errorMessage => 'dude, bind first',
195			resultCode => LDAP_OPERATIONS_ERROR,
196			};
197			}
198
199			my $filter;
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))';
208			}
209
210			warn "search upstream for $filter\n";
211
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},
219			filter => $filter,
220			attrs => $req->{attributes},
221			raw => qr/.*/,
222			);
223
224			# warn "# search = ",dump( $search );
225
226			if ( $search->code != LDAP_SUCCESS ) {
227			warn "ERROR: ",$search->code,": ",$search->server_error;
228			return {
229			matchedDN => '',
230			errorMessage => $search->server_error,
231			resultCode => $search->code,
232			};
233			};
234
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);
242			# }
243			# }
244			}
245
246			warn "## entries = ",dump( @entries );
247
248	dpavlin	31	my $path = 'var/' . uri_escape( $filter ) . '.yml';
249			DumpFile( $path, \@entries );
250	dpavlin	6	warn "# created $path ", -s $path, " bytes";
251
252	dpavlin	1	return RESULT_OK, @entries;
253			}
254
255			# the rest of the operations will return an "unwilling to perform"
256
257			1;