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

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';

        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";

        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;
        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	222	use constant RESULT_OK => {
21			'matchedDN' => '',
22			'errorMessage' => '',
23			'resultCode' => LDAP_SUCCESS
24			};
25
26			# constructor
27			sub new {
28			my ($class, $sock) = @_;
29			my $self = $class->SUPER::new($sock);
30			printf "Accepted connection from: %s\n", $sock->peerhost();
31			return $self;
32			}
33
34			# the bind operation
35			sub bind {
36	dpavlin	223	my ($self,$req) = @_;
37
38			warn "## bind req = ",dump($req);
39
40			defined($req->{authentication}->{simple}) or return {
41			matchedDN => '',
42			errorMessage => '',
43			resultCode => LDAP_STRONG_AUTH_NOT_SUPPORTED,
44			};
45
46			$self->{upstream} \|\|= A3C::LDAP->new->ldap or return {
47			matchedDN => '',
48			errorMessage => $@,
49			resultCode => LDAP_UNAVAILABLE,
50			};
51
52			warn "## upstream = ",dump( $self->{upstream} );
53			# warn "upstream not Net::LDAP but ",ref($self->{upstream}) unless ref($self->{upstream}) eq 'Net::LDAP';
54
55	dpavlin	222	return RESULT_OK;
56			}
57
58			# the search operation
59			sub search {
60	dpavlin	223	my ($self,$req) = @_;
61	dpavlin	222
62	dpavlin	223	warn "## search req = ",dump( $req );
63
64			if ( ! $self->{upstream} ) {
65			warn "search without bind";
66			return {
67			matchedDN => '',
68			errorMessage => 'dude, bind first',
69			resultCode => LDAP_OPERATIONS_ERROR,
70			};
71	dpavlin	222	}
72	dpavlin	223
73			my $filter;
74			if (defined $req->{filter}) {
75			# $req->{filter} is a ASN1-decoded tree; luckily, this is exactly the
76			# internal representation Net::LDAP::Filter uses. [FIXME] Eventually
77			# Net::LDAP::Filter should provide a corresponding constructor.
78			bless($req->{filter}, 'Net::LDAP::Filter');
79			$filter = $req->{filter}->as_string;
80			# $filter = '(&' . $req->{filter}->as_string
81			# . '(objectClass=hrEduPerson)(host=aai.irb.hr))';
82			}
83
84			warn "search upstream for $filter";
85
86			my $search = $self->{upstream}->search(
87			base => $req->{baseObject},
88			scope => $req->{scope},
89			deref => $req->{derefAliases},
90			sizelimit => $req->{sizeLimit},
91			timelimit => $req->{timeLimit},
92			typesonly => $req->{typesOnly},
93			filter => $filter,
94			attrs => $req->{attributes},
95			raw => qr/.*/,
96			);
97
98			warn "# search = ",dump( $search );
99
100			if ( $search->code != LDAP_SUCCESS ) {
101			warn "ERROR: ",$search->code,": ",$search->server_error;
102			return {
103			matchedDN => '',
104			errorMessage => $search->server_error,
105			resultCode => $search->code,
106			};
107			};
108
109			my @entries = $search->entries;
110			warn "## got ", $search->count, " entries for ", $filter;
111			foreach my $entry (@entries) {
112			$entry->changetype('add'); # Don't record changes.
113			# foreach my $attr ($entry->attributes) {
114			# if ($attr =~ /;lang-en$/) {
115			# $entry->delete($attr);
116			# }
117			# }
118			}
119
120			warn "## entries = ",dump( @entries );
121	dpavlin	222	return RESULT_OK, @entries;
122			}
123
124			# the rest of the operations will return an "unwilling to perform"
125
126			1;