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 'Net::LDAP::Server';
use fields qw(upstream);

use A3C::LDAP;
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>

=cut

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 );
        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	222	use base 'Net::LDAP::Server';
15	dpavlin	223	use fields qw(upstream);
16	dpavlin	222
17	dpavlin	223	use A3C::LDAP;
18			use Data::Dump qw/dump/;
19
20	dpavlin	225	=head1 NAME
21
22			A3C::LDAP::Server
23
24			=cut
25
26			=head1 DESCRIPTION
27
28			Provide LDAP server functionality for L<A3C> somewhat similar to C<slapo-rwm>
29
30			=cut
31
32	dpavlin	222	use constant RESULT_OK => {
33			'matchedDN' => '',
34			'errorMessage' => '',
35			'resultCode' => LDAP_SUCCESS
36			};
37
38			# constructor
39			sub new {
40			my ($class, $sock) = @_;
41			my $self = $class->SUPER::new($sock);
42			printf "Accepted connection from: %s\n", $sock->peerhost();
43			return $self;
44			}
45
46			# the bind operation
47			sub bind {
48	dpavlin	223	my ($self,$req) = @_;
49
50			warn "## bind req = ",dump($req);
51
52			defined($req->{authentication}->{simple}) or return {
53			matchedDN => '',
54			errorMessage => '',
55			resultCode => LDAP_STRONG_AUTH_NOT_SUPPORTED,
56			};
57
58			$self->{upstream} \|\|= A3C::LDAP->new->ldap or return {
59			matchedDN => '',
60			errorMessage => $@,
61			resultCode => LDAP_UNAVAILABLE,
62			};
63
64	dpavlin	224	# warn "## upstream = ",dump( $self->{upstream} );
65	dpavlin	223	# warn "upstream not Net::LDAP but ",ref($self->{upstream}) unless ref($self->{upstream}) eq 'Net::LDAP';
66
67	dpavlin	226	my $msg;
68
69			# FIXME we would need to unbind because A3C::LDAP binds us automatically, but that doesn't really work
70			#$msg = $self->{upstream}->unbind;
71			#warn "# unbind msg = ",dump( $msg );
72
73			$msg = $self->{upstream}->bind(
74			dn => $req->{name},
75			password => $req->{authentication}->{simple}
76			);
77
78			warn "# bind msg = ",dump( $msg );
79			if ( $msg->code != LDAP_SUCCESS ) {
80			warn "ERROR: ", $msg->code, ": ", $msg->server_error, "\n";
81			return {
82			matchedDN => '',
83			errorMessage => $msg->server_error,
84			resultCode => $msg->code,
85			};
86			}
87
88	dpavlin	222	return RESULT_OK;
89			}
90
91			# the search operation
92			sub search {
93	dpavlin	223	my ($self,$req) = @_;
94	dpavlin	222
95	dpavlin	223	warn "## search req = ",dump( $req );
96
97			if ( ! $self->{upstream} ) {
98			warn "search without bind";
99			return {
100			matchedDN => '',
101			errorMessage => 'dude, bind first',
102			resultCode => LDAP_OPERATIONS_ERROR,
103			};
104	dpavlin	222	}
105	dpavlin	223
106			my $filter;
107			if (defined $req->{filter}) {
108			# $req->{filter} is a ASN1-decoded tree; luckily, this is exactly the
109			# internal representation Net::LDAP::Filter uses. [FIXME] Eventually
110			# Net::LDAP::Filter should provide a corresponding constructor.
111			bless($req->{filter}, 'Net::LDAP::Filter');
112			$filter = $req->{filter}->as_string;
113			# $filter = '(&' . $req->{filter}->as_string
114			# . '(objectClass=hrEduPerson)(host=aai.irb.hr))';
115			}
116
117	dpavlin	224	warn "search upstream for $filter\n";
118	dpavlin	223
119			my $search = $self->{upstream}->search(
120			base => $req->{baseObject},
121			scope => $req->{scope},
122			deref => $req->{derefAliases},
123			sizelimit => $req->{sizeLimit},
124			timelimit => $req->{timeLimit},
125			typesonly => $req->{typesOnly},
126			filter => $filter,
127			attrs => $req->{attributes},
128			raw => qr/.*/,
129			);
130
131	dpavlin	224	# warn "# search = ",dump( $search );
132	dpavlin	223
133			if ( $search->code != LDAP_SUCCESS ) {
134			warn "ERROR: ",$search->code,": ",$search->server_error;
135			return {
136			matchedDN => '',
137			errorMessage => $search->server_error,
138			resultCode => $search->code,
139			};
140			};
141
142			my @entries = $search->entries;
143	dpavlin	224	warn "## got ", $search->count, " entries for $filter\n";
144	dpavlin	223	foreach my $entry (@entries) {
145	dpavlin	225	# $entry->changetype('add'); # Don't record changes.
146	dpavlin	223	# foreach my $attr ($entry->attributes) {
147			# if ($attr =~ /;lang-en$/) {
148			# $entry->delete($attr);
149			# }
150			# }
151			}
152
153			warn "## entries = ",dump( @entries );
154	dpavlin	222	return RESULT_OK, @entries;
155			}
156
157			# the rest of the operations will return an "unwilling to perform"
158
159			1;